diff options
Diffstat (limited to 'ghc/compiler/nativeGen')
36 files changed, 4301 insertions, 903 deletions
diff --git a/ghc/compiler/nativeGen/AbsCStixGen.hi b/ghc/compiler/nativeGen/AbsCStixGen.hi index 96ac402b50..867abb4089 100644 --- a/ghc/compiler/nativeGen/AbsCStixGen.hi +++ b/ghc/compiler/nativeGen/AbsCStixGen.hi @@ -5,24 +5,21 @@ import BasicLit(BasicLit) import CLabelInfo(CLabel) import CharSeq(CSeq) import ClosureInfo(ClosureInfo) -import CmdLineOpts(GlobalSwitch, SwitchResult) import CostCentre(CostCentre) import HeapOffs(HeapOffset) import MachDesc(RegLoc, Target) import Maybes(Labda) import PreludePS(_PackedString) import PreludeRatio(Ratio(..)) -import Pretty(PprStyle) import PrimKind(PrimKind) import PrimOps(PrimOp) import SMRep(SMRep) import SplitUniq(SUniqSM(..), SplitUniqSupply) import Stix(CodeSegment, StixReg, StixTree) -data AbstractC {-# GHC_PRAGMA AbsCNop | AbsCStmts AbstractC AbstractC | CAssign CAddrMode CAddrMode | CJump CAddrMode | CFallThrough CAddrMode | CReturn CAddrMode ReturnInfo | CSwitch CAddrMode [(BasicLit, AbstractC)] AbstractC | CCodeBlock CLabel AbstractC | CInitHdr ClosureInfo RegRelative CAddrMode Bool | COpStmt [CAddrMode] PrimOp [CAddrMode] Int [MagicId] | CSimultaneous AbstractC | CMacroStmt CStmtMacro [CAddrMode] | CCallProfCtrMacro _PackedString [CAddrMode] | CCallProfCCMacro _PackedString [CAddrMode] | CStaticClosure CLabel ClosureInfo CAddrMode [CAddrMode] | CClosureInfoAndCode ClosureInfo AbstractC (Labda AbstractC) CAddrMode [Char] | CRetVector CLabel [Labda CAddrMode] AbstractC | CRetUnVector CLabel CAddrMode | CFlatRetVector CLabel [CAddrMode] | CCostCentreDecl Bool CostCentre | CClosureUpdInfo AbstractC | CSplitMarker #-} -data Target {-# GHC_PRAGMA Target (GlobalSwitch -> SwitchResult) Int (SMRep -> Int) (MagicId -> RegLoc) (StixTree -> StixTree) (PrimKind -> Int) ([MagicId] -> [StixTree]) ([MagicId] -> [StixTree]) (HeapOffset -> Int) (CAddrMode -> StixTree) (CAddrMode -> StixTree) Int Int StixTree StixTree ([CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) Bool ([Char] -> [Char]) #-} +data AbstractC +data Target type SUniqSM a = SplitUniqSupply -> a -data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-} -data StixTree {-# GHC_PRAGMA StSegment CodeSegment | StInt Integer | StDouble (Ratio Integer) | StString _PackedString | StLitLbl CSeq | StLitLit _PackedString | StCLbl CLabel | StReg StixReg | StIndex PrimKind StixTree StixTree | StInd PrimKind StixTree | StAssign PrimKind StixTree StixTree | StLabel CLabel | StFunBegin CLabel | StFunEnd CLabel | StJump StixTree | StFallThrough CLabel | StCondJump CLabel StixTree | StData PrimKind [StixTree] | StPrim PrimOp [StixTree] | StCall _PackedString PrimKind [StixTree] | StComment _PackedString #-} +data SplitUniqSupply +data StixTree genCodeAbstractC :: Target -> AbstractC -> SplitUniqSupply -> [[StixTree]] - {-# GHC_PRAGMA _A_ 2 _U_ 221 _N_ _N_ _N_ _N_ #-} diff --git a/ghc/compiler/nativeGen/AbsCStixGen.lhs b/ghc/compiler/nativeGen/AbsCStixGen.lhs index 67d4e1559e..718775a3d5 100644 --- a/ghc/compiler/nativeGen/AbsCStixGen.lhs +++ b/ghc/compiler/nativeGen/AbsCStixGen.lhs @@ -38,62 +38,74 @@ where each tree corresponds to a single Stix instruction. We leave the chunks separated so that register allocation can be performed locally within the chunk. \begin{code} +-- hacking with Uncle Will: +#define target_STRICT target@(Target _ _ _ _ _ _ _ _) genCodeAbstractC :: Target -> AbstractC -> SUniqSM [[StixTree]] -genCodeAbstractC target absC = - mapSUs (genCodeTopAbsC target) (mkAbsCStmtList absC) `thenSUs` \ trees -> +genCodeAbstractC target_STRICT absC = + mapSUs gentopcode (mkAbsCStmtList absC) `thenSUs` \ trees -> returnSUs ([StComment SLIT("Native Code")] : trees) - + where + -- "target" munging things... --- + a2stix = amodeToStix target + a2stix' = amodeToStix' target + volsaves = volatileSaves target + volrestores = volatileRestores target + p2stix = primToStix target + macro_code = macroCode target + hp_rel = hpRel target + -- real code follows... --------- \end{code} Here we handle top-level things, like @CCodeBlock@s and @CClosureInfoTable@s. \begin{code} - -genCodeTopAbsC + {- + genCodeTopAbsC :: Target -> AbstractC -> SUniqSM [StixTree] + -} -genCodeTopAbsC target (CCodeBlock label absC) = - genCodeAbsC target absC `thenSUs` \ code -> + gentopcode (CCodeBlock label absC) = + gencode absC `thenSUs` \ code -> returnSUs (StSegment TextSegment : StFunBegin label : code [StFunEnd label]) -genCodeTopAbsC target stmt@(CStaticClosure label _ _ _) = - genCodeStaticClosure target stmt `thenSUs` \ code -> + gentopcode stmt@(CStaticClosure label _ _ _) = + genCodeStaticClosure stmt `thenSUs` \ code -> returnSUs (StSegment DataSegment : StLabel label : code []) -genCodeTopAbsC target stmt@(CRetUnVector _ _) = returnSUs [] + gentopcode stmt@(CRetUnVector _ _) = returnSUs [] -genCodeTopAbsC target stmt@(CFlatRetVector label _) = - genCodeVecTbl target stmt `thenSUs` \ code -> + gentopcode stmt@(CFlatRetVector label _) = + genCodeVecTbl stmt `thenSUs` \ code -> returnSUs (StSegment TextSegment : code [StLabel label]) -genCodeTopAbsC target stmt@(CClosureInfoAndCode cl_info slow Nothing _ _) + gentopcode stmt@(CClosureInfoAndCode cl_info slow Nothing _ _ _) | slow_is_empty - = genCodeInfoTable target stmt `thenSUs` \ itbl -> + = genCodeInfoTable hp_rel a2stix stmt `thenSUs` \ itbl -> returnSUs (StSegment TextSegment : itbl []) | otherwise - = genCodeInfoTable target stmt `thenSUs` \ itbl -> - genCodeAbsC target slow `thenSUs` \ slow_code -> + = genCodeInfoTable hp_rel a2stix stmt `thenSUs` \ itbl -> + gencode slow `thenSUs` \ slow_code -> returnSUs (StSegment TextSegment : itbl (StFunBegin slow_lbl : slow_code [StFunEnd slow_lbl])) where slow_is_empty = not (maybeToBool (nonemptyAbsC slow)) slow_lbl = entryLabelFromCI cl_info -genCodeTopAbsC target stmt@(CClosureInfoAndCode cl_info slow (Just fast) _ _) = --- ToDo: what if this is empty? ------------------------^^^^ - genCodeInfoTable target stmt `thenSUs` \ itbl -> - genCodeAbsC target slow `thenSUs` \ slow_code -> - genCodeAbsC target fast `thenSUs` \ fast_code -> + gentopcode stmt@(CClosureInfoAndCode cl_info slow (Just fast) _ _ _) = + -- ToDo: what if this is empty? ------------------------^^^^ + genCodeInfoTable hp_rel a2stix stmt `thenSUs` \ itbl -> + gencode slow `thenSUs` \ slow_code -> + gencode fast `thenSUs` \ fast_code -> returnSUs (StSegment TextSegment : itbl (StFunBegin slow_lbl : slow_code (StFunEnd slow_lbl : StFunBegin fast_lbl : fast_code [StFunEnd fast_lbl]))) @@ -101,28 +113,75 @@ genCodeTopAbsC target stmt@(CClosureInfoAndCode cl_info slow (Just fast) _ _) = slow_lbl = entryLabelFromCI cl_info fast_lbl = fastLabelFromCI cl_info -genCodeTopAbsC target absC = - genCodeAbsC target absC `thenSUs` \ code -> + gentopcode absC = + gencode absC `thenSUs` \ code -> returnSUs (StSegment TextSegment : code []) \end{code} -Now the individual AbstractC statements. +Vector tables are trivial! \begin{code} + {- + genCodeVecTbl + :: Target + -> AbstractC + -> SUniqSM StixTreeList + -} + genCodeVecTbl (CFlatRetVector label amodes) = + returnSUs (\xs -> vectbl : xs) + where + vectbl = StData PtrKind (reverse (map a2stix amodes)) + +\end{code} + +Static closures are not so hard either. -genCodeAbsC +\begin{code} + {- + genCodeStaticClosure :: Target -> AbstractC -> SUniqSM StixTreeList + -} + genCodeStaticClosure (CStaticClosure _ cl_info cost_centre amodes) = + returnSUs (\xs -> table : xs) + where + table = StData PtrKind (StCLbl info_lbl : body) + info_lbl = infoTableLabelFromCI cl_info + + body = if closureUpdReqd cl_info then + take (max mIN_UPD_SIZE (length amodes')) (amodes' ++ zeros) + else + amodes' + + zeros = StInt 0 : zeros + + amodes' = map amodeZeroVoid amodes + + -- Watch out for VoidKinds...cf. PprAbsC + amodeZeroVoid item + | getAmodeKind item == VoidKind = StInt 0 + | otherwise = a2stix item + +\end{code} + +Now the individual AbstractC statements. +\begin{code} + {- + gencode + :: Target + -> AbstractC + -> SUniqSM StixTreeList + -} \end{code} @AbsCNop@s just disappear. \begin{code} -genCodeAbsC target AbsCNop = returnSUs id + gencode AbsCNop = returnSUs id \end{code} @@ -130,7 +189,7 @@ OLD:@CComment@s are passed through as the corresponding @StComment@s. \begin{code} ---UNUSED:genCodeAbsC target (CComment s) = returnSUs (\xs -> StComment s : xs) + --UNUSED:gencode (CComment s) = returnSUs (\xs -> StComment s : xs) \end{code} @@ -138,7 +197,7 @@ Split markers are a NOP in this land. \begin{code} -genCodeAbsC target CSplitMarker = returnSUs id + gencode CSplitMarker = returnSUs id \end{code} @@ -147,9 +206,9 @@ resulting StixTreeLists are joined together. \begin{code} -genCodeAbsC target (AbsCStmts c1 c2) = - genCodeAbsC target c1 `thenSUs` \ b1 -> - genCodeAbsC target c2 `thenSUs` \ b2 -> + gencode (AbsCStmts c1 c2) = + gencode c1 `thenSUs` \ b1 -> + gencode c2 `thenSUs` \ b2 -> returnSUs (b1 . b2) \end{code} @@ -162,9 +221,9 @@ addresses, etc.) \begin{code} -genCodeAbsC target (CInitHdr cl_info reg_rel _ _) = + gencode (CInitHdr cl_info reg_rel _ _) = let - lhs = amodeToStix target (CVal reg_rel PtrKind) + lhs = a2stix (CVal reg_rel PtrKind) lbl = infoTableLabelFromCI cl_info in returnSUs (\xs -> StAssign PtrKind lhs (StCLbl lbl) : xs) @@ -180,13 +239,13 @@ of the source? Be careful about floats/doubles. \begin{code} -genCodeAbsC target (CAssign lhs rhs) + gencode (CAssign lhs rhs) | getAmodeKind lhs == VoidKind = returnSUs id | otherwise = let pk = getAmodeKind lhs pk' = if mixedTypeLocn lhs && not (isFloatingKind pk) then IntKind else pk - lhs' = amodeToStix target lhs - rhs' = amodeToStix' target rhs + lhs' = a2stix lhs + rhs' = a2stix' rhs in returnSUs (\xs -> StAssign pk' lhs' rhs' : xs) @@ -198,26 +257,26 @@ with the address of the info table before jumping to the entry code for Node. \begin{code} -genCodeAbsC target (CJump dest) = - returnSUs (\xs -> StJump (amodeToStix target dest) : xs) + gencode (CJump dest) = + returnSUs (\xs -> StJump (a2stix dest) : xs) -genCodeAbsC target (CFallThrough (CLbl lbl _)) = + gencode (CFallThrough (CLbl lbl _)) = returnSUs (\xs -> StFallThrough lbl : xs) -genCodeAbsC target (CReturn dest DirectReturn) = - returnSUs (\xs -> StJump (amodeToStix target dest) : xs) + gencode (CReturn dest DirectReturn) = + returnSUs (\xs -> StJump (a2stix dest) : xs) -genCodeAbsC target (CReturn table (StaticVectoredReturn n)) = + gencode (CReturn table (StaticVectoredReturn n)) = returnSUs (\xs -> StJump dest : xs) where - dest = StInd PtrKind (StIndex PtrKind (amodeToStix target table) + dest = StInd PtrKind (StIndex PtrKind (a2stix table) (StInt (toInteger (-n-1)))) -genCodeAbsC target (CReturn table (DynamicVectoredReturn am)) = + gencode (CReturn table (DynamicVectoredReturn am)) = returnSUs (\xs -> StJump dest : xs) where - dest = StInd PtrKind (StIndex PtrKind (amodeToStix target table) dyn_off) - dyn_off = StPrim IntSubOp [StPrim IntNegOp [amodeToStix target am], StInt 1] + dest = StInd PtrKind (StIndex PtrKind (a2stix table) dyn_off) + dyn_off = StPrim IntSubOp [StPrim IntNegOp [a2stix am], StInt 1] \end{code} @@ -225,18 +284,18 @@ Now the PrimOps, some of which may need caller-saves register wrappers. \begin{code} -genCodeAbsC target (COpStmt results op args liveness_mask vols) + gencode (COpStmt results op args liveness_mask vols) -- ToDo (ADR?): use that liveness mask | primOpNeedsWrapper op = let - saves = volatileSaves target vols - restores = volatileRestores target vols + saves = volsaves vols + restores = volrestores vols in - primToStix target (nonVoid results) op (nonVoid args) + p2stix (nonVoid results) op (nonVoid args) `thenSUs` \ code -> returnSUs (\xs -> saves ++ code (restores ++ xs)) - | otherwise = primToStix target (nonVoid results) op (nonVoid args) + | otherwise = p2stix (nonVoid results) op (nonVoid args) where nonVoid = filter ((/= VoidKind) . getAmodeKind) @@ -260,27 +319,27 @@ Now the if statement. Almost *all* flow of control are of this form. \begin{code} -genCodeAbsC target (CSwitch discrim alts deflt) + gencode (CSwitch discrim alts deflt) = case alts of - [] -> genCodeAbsC target deflt + [] -> gencode deflt [(tag,alt_code)] -> case maybe_empty_deflt of - Nothing -> genCodeAbsC target alt_code - Just dc -> mkIfThenElse target discrim tag alt_code dc + Nothing -> gencode alt_code + Just dc -> mkIfThenElse discrim tag alt_code dc [(tag1@(MachInt i1 _), alt_code1), (tag2@(MachInt i2 _), alt_code2)] | deflt_is_empty && i1 == 0 && i2 == 1 - -> mkIfThenElse target discrim tag1 alt_code1 alt_code2 + -> mkIfThenElse discrim tag1 alt_code1 alt_code2 | deflt_is_empty && i1 == 1 && i2 == 0 - -> mkIfThenElse target discrim tag2 alt_code2 alt_code1 + -> mkIfThenElse discrim tag2 alt_code2 alt_code1 -- If the @discrim@ is simple, then this unfolding is safe. - other | simple_discrim -> mkSimpleSwitches target discrim alts deflt + other | simple_discrim -> mkSimpleSwitches discrim alts deflt -- Otherwise, we need to do a bit of work. other -> getSUnique `thenSUs` \ u -> - genCodeAbsC target (AbsCStmts + gencode (AbsCStmts (CAssign (CTemp u pk) discrim) (CSwitch (CTemp u pk) alts deflt)) @@ -304,12 +363,12 @@ Finally, all of the disgusting AbstractC macros. \begin{code} -genCodeAbsC target (CMacroStmt macro args) = macroCode target macro args + gencode (CMacroStmt macro args) = macro_code macro args -genCodeAbsC target (CCallProfCtrMacro macro _) = + gencode (CCallProfCtrMacro macro _) = returnSUs (\xs -> StComment macro : xs) -genCodeAbsC target (CCallProfCCMacro macro _) = + gencode (CCallProfCCMacro macro _) = returnSUs (\xs -> StComment macro : xs) \end{code} @@ -320,26 +379,27 @@ comparison tree. (Perhaps this could be tuned.) \begin{code} -intTag :: BasicLit -> Integer -intTag (MachChar c) = toInteger (ord c) -intTag (MachInt i _) = i -intTag _ = panic "intTag" + intTag :: BasicLit -> Integer + intTag (MachChar c) = toInteger (ord c) + intTag (MachInt i _) = i + intTag _ = panic "intTag" -fltTag :: BasicLit -> Rational + fltTag :: BasicLit -> Rational -fltTag (MachFloat f) = f -fltTag (MachDouble d) = d -fltTag _ = panic "fltTag" + fltTag (MachFloat f) = f + fltTag (MachDouble d) = d + fltTag _ = panic "fltTag" -mkSimpleSwitches + {- + mkSimpleSwitches :: Target -> CAddrMode -> [(BasicLit,AbstractC)] -> AbstractC -> SUniqSM StixTreeList - -mkSimpleSwitches target am alts absC = + -} + mkSimpleSwitches am alts absC = getUniqLabelNCG `thenSUs` \ udlbl -> getUniqLabelNCG `thenSUs` \ ujlbl -> - let am' = amodeToStix target am + let am' = a2stix am joinedAlts = map (\ (tag,code) -> (tag, mkJoin code ujlbl)) alts sortedAlts = naturalMergeSortLe leAlt joinedAlts -- naturalMergeSortLe, because we often get sorted alts to begin with @@ -361,12 +421,12 @@ mkSimpleSwitches target am alts absC = in ( if not floating && choices > 4 && highTag - lowTag < toInteger (2 * choices) then - mkJumpTable target am' sortedAlts lowTag highTag udlbl + mkJumpTable am' sortedAlts lowTag highTag udlbl else - mkBinaryTree target am' floating sortedAlts choices lowest highest udlbl + mkBinaryTree am' floating sortedAlts choices lowest highest udlbl ) `thenSUs` \ alt_code -> - genCodeAbsC target absC `thenSUs` \ dflt_code -> + gencode absC `thenSUs` \ dflt_code -> returnSUs (\xs -> alt_code (StLabel udlbl : dflt_code (StLabel ujlbl : xs))) @@ -390,8 +450,8 @@ If a join is necessary after the switch, the alternatives should already finish with a jump to the join point. \begin{code} - -mkJumpTable + {- + mkJumpTable :: Target -> StixTree -- discriminant -> [(BasicLit, AbstractC)] -- alternatives @@ -399,8 +459,9 @@ mkJumpTable -> Integer -- high tag -> CLabel -- default label -> SUniqSM StixTreeList + -} -mkJumpTable target am alts lowTag highTag dflt = + mkJumpTable am alts lowTag highTag dflt = getUniqLabelNCG `thenSUs` \ utlbl -> mapSUs genLabel alts `thenSUs` \ branches -> let cjmpLo = StCondJump dflt (StPrim IntLtOp [am, StInt lowTag]) @@ -422,7 +483,7 @@ mkJumpTable target am alts lowTag highTag dflt = genLabel x = getUniqLabelNCG `thenSUs` \ lbl -> returnSUs (lbl, x) mkBranch (lbl,(_,alt)) = - genCodeAbsC target alt `thenSUs` \ alt_code -> + gencode alt `thenSUs` \ alt_code -> returnSUs (\xs -> StLabel lbl : alt_code xs) mkTable _ [] tbl = reverse tbl @@ -446,8 +507,8 @@ As with the jump table approach, if a join is necessary after the switch, the alternatives should already finish with a jump to the join point. \begin{code} - -mkBinaryTree + {- + mkBinaryTree :: Target -> StixTree -- discriminant -> Bool -- floating point? @@ -457,32 +518,33 @@ mkBinaryTree -> BasicLit -- high tag -> CLabel -- default code label -> SUniqSM StixTreeList + -} -mkBinaryTree target am floating [(tag,alt)] _ lowTag highTag udlbl - | rangeOfOne = genCodeAbsC target alt + mkBinaryTree am floating [(tag,alt)] _ lowTag highTag udlbl + | rangeOfOne = gencode alt | otherwise = - let tag' = amodeToStix target (CLit tag) + let tag' = a2stix (CLit tag) cmpOp = if floating then DoubleNeOp else IntNeOp test = StPrim cmpOp [am, tag'] cjmp = StCondJump udlbl test in - genCodeAbsC target alt `thenSUs` \ alt_code -> + gencode alt `thenSUs` \ alt_code -> returnSUs (\xs -> cjmp : alt_code xs) where rangeOfOne = not floating && intTag lowTag + 1 >= intTag highTag -- When there is only one possible tag left in range, we skip the comparison -mkBinaryTree target am floating alts choices lowTag highTag udlbl = + mkBinaryTree am floating alts choices lowTag highTag udlbl = getUniqLabelNCG `thenSUs` \ uhlbl -> - let tag' = amodeToStix target (CLit splitTag) + let tag' = a2stix (CLit splitTag) cmpOp = if floating then DoubleGeOp else IntGeOp test = StPrim cmpOp [am, tag'] cjmp = StCondJump uhlbl test in - mkBinaryTree target am floating alts_lo half lowTag splitTag udlbl + mkBinaryTree am floating alts_lo half lowTag splitTag udlbl `thenSUs` \ lo_code -> - mkBinaryTree target am floating alts_hi (choices - half) splitTag highTag udlbl + mkBinaryTree am floating alts_hi (choices - half) splitTag highTag udlbl `thenSUs` \ hi_code -> returnSUs (\xs -> cjmp : lo_code (StLabel uhlbl : hi_code xs)) @@ -495,28 +557,29 @@ mkBinaryTree target am floating alts choices lowTag highTag udlbl = \end{code} \begin{code} - -mkIfThenElse + {- + mkIfThenElse :: Target -> CAddrMode -- discriminant -> BasicLit -- tag -> AbstractC -- if-part -> AbstractC -- else-part -> SUniqSM StixTreeList + -} -mkIfThenElse target discrim tag alt deflt = + mkIfThenElse discrim tag alt deflt = getUniqLabelNCG `thenSUs` \ ujlbl -> getUniqLabelNCG `thenSUs` \ utlbl -> - let discrim' = amodeToStix target discrim - tag' = amodeToStix target (CLit tag) + let discrim' = a2stix discrim + tag' = a2stix (CLit tag) cmpOp = if (isFloatingKind (getAmodeKind discrim)) then DoubleNeOp else IntNeOp test = StPrim cmpOp [discrim', tag'] cjmp = StCondJump utlbl test dest = StLabel utlbl join = StLabel ujlbl in - genCodeAbsC target (mkJoin alt ujlbl) `thenSUs` \ alt_code -> - genCodeAbsC target deflt `thenSUs` \ dflt_code -> + gencode (mkJoin alt ujlbl) `thenSUs` \ alt_code -> + gencode deflt `thenSUs` \ dflt_code -> returnSUs (\xs -> cjmp : alt_code (dest : dflt_code (join : xs))) mkJoin :: AbstractC -> CLabel -> AbstractC @@ -524,7 +587,6 @@ mkJoin :: AbstractC -> CLabel -> AbstractC mkJoin code lbl | mightFallThrough code = mkAbsCStmts code (CJump (CLbl lbl PtrKind)) | otherwise = code - \end{code} %--------------------------------------------------------------------------- @@ -566,51 +628,3 @@ isEmptyAbsC :: AbstractC -> Bool isEmptyAbsC = not . maybeToBool . nonemptyAbsC ================= End of old, quadratic, algorithm -} \end{code} - -Vector tables are trivial! - -\begin{code} - -genCodeVecTbl - :: Target - -> AbstractC - -> SUniqSM StixTreeList - -genCodeVecTbl target (CFlatRetVector label amodes) = - returnSUs (\xs -> vectbl : xs) - where - vectbl = StData PtrKind (reverse (map (amodeToStix target) amodes)) - -\end{code} - -Static closures are not so hard either. - -\begin{code} - -genCodeStaticClosure - :: Target - -> AbstractC - -> SUniqSM StixTreeList - -genCodeStaticClosure target (CStaticClosure _ cl_info cost_centre amodes) = - returnSUs (\xs -> table : xs) - where - table = StData PtrKind (StCLbl info_lbl : body) - info_lbl = infoTableLabelFromCI cl_info - - body = if closureUpdReqd cl_info then - take (max mIN_UPD_SIZE (length amodes')) (amodes' ++ zeros) - else - amodes' - - zeros = StInt 0 : zeros - - amodes' = map amodeZeroVoid amodes - - -- Watch out for VoidKinds...cf. PprAbsC - amodeZeroVoid item - | getAmodeKind item == VoidKind = StInt 0 - | otherwise = amodeToStix target item - -\end{code} - diff --git a/ghc/compiler/nativeGen/AlphaCode.hi b/ghc/compiler/nativeGen/AlphaCode.hi index 540276dc81..1b9966ca18 100644 --- a/ghc/compiler/nativeGen/AlphaCode.hi +++ b/ghc/compiler/nativeGen/AlphaCode.hi @@ -19,68 +19,39 @@ data Addr = AddrImm Imm | AddrReg Reg | AddrRegImm Reg Imm type AlphaCode = OrdList AlphaInstr data AlphaInstr = LD Size Reg Addr | LDA Reg Addr | LDAH Reg Addr | LDGP Reg Addr | LDI Size Reg Imm | ST Size Reg Addr | CLR Reg | ABS Size RI Reg | NEG Size Bool RI Reg | ADD Size Bool Reg RI Reg | SADD Size Size Reg RI Reg | SUB Size Bool Reg RI Reg | SSUB Size Size Reg RI Reg | MUL Size Bool Reg RI Reg | DIV Size Bool Reg RI Reg | REM Size Bool Reg RI Reg | NOT RI Reg | AND Reg RI Reg | ANDNOT Reg RI Reg | OR Reg RI Reg | ORNOT Reg RI Reg | XOR Reg RI Reg | XORNOT Reg RI Reg | SLL Reg RI Reg | SRL Reg RI Reg | SRA Reg RI Reg | ZAP Reg RI Reg | ZAPNOT Reg RI Reg | NOP | CMP Cond Reg RI Reg | FCLR Reg | FABS Reg Reg | FNEG Size Reg Reg | FADD Size Reg Reg Reg | FDIV Size Reg Reg Reg | FMUL Size Reg Reg Reg | FSUB Size Reg Reg Reg | CVTxy Size Size Reg Reg | FCMP Size Cond Reg Reg Reg | FMOV Reg Reg | BI Cond Reg Imm | BF Cond Reg Imm | BR Imm | JMP Reg Addr Int | BSR Imm Int | JSR Reg Addr Int | LABEL CLabel | FUNBEGIN CLabel | FUNEND CLabel | COMMENT _PackedString | SEGMENT CodeSegment | ASCII Bool [Char] | DATA Size [Imm] -data AlphaRegs {-# GHC_PRAGMA SRegs BitSet BitSet #-} -data MagicId {-# GHC_PRAGMA BaseReg | StkOReg | VanillaReg PrimKind Int# | FloatReg Int# | DoubleReg Int# | TagReg | RetReg | SpA | SuA | SpB | SuB | Hp | HpLim | LivenessReg | ActivityReg | StdUpdRetVecReg | StkStubReg | CurCostCentre | VoidReg #-} -data Reg {-# GHC_PRAGMA FixedReg Int# | MappedReg Int# | MemoryReg Int PrimKind | UnmappedReg Unique PrimKind #-} -data BitSet {-# GHC_PRAGMA MkBS Word# #-} +data AlphaRegs +data MagicId +data Reg +data BitSet data CLabel -data CSeq {-# GHC_PRAGMA CNil | CAppend CSeq CSeq | CIndent Int CSeq | CNewline | CStr [Char] | CCh Char | CInt Int | CPStr _PackedString #-} +data CSeq data Cond = EQ | LT | LE | ULT | ULE | NE | GT | GE | ALWAYS | NEVER -data FiniteMap a b {-# GHC_PRAGMA EmptyFM | Branch a b Int# (FiniteMap a b) (FiniteMap a b) #-} +data FiniteMap a b data Imm = ImmInt Int | ImmInteger Integer | ImmCLbl CLabel | ImmLab CSeq -data OrdList a {-# GHC_PRAGMA SeqList (OrdList a) (OrdList a) | ParList (OrdList a) (OrdList a) | OrdObj a | NoObj #-} -data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-} -data CodeSegment {-# GHC_PRAGMA DataSegment | TextSegment #-} +data OrdList a +data PrimKind +data CodeSegment data RI = RIReg Reg | RIImm Imm data Size = B | BU | W | WU | L | Q | FF | DF | GF | SF | TF -data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-} +data UniqFM a type UniqSet a = UniqFM a -data Unique {-# GHC_PRAGMA MkUnique Int# #-} +data Unique argRegs :: [(Reg, Reg)] - {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} baseRegOffset :: MagicId -> Int - {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} callerSaves :: MagicId -> Bool - {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} f0 :: Reg - {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} freeRegs :: [Reg] - {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} gp :: Reg - {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [29#] _N_ #-} kindToSize :: PrimKind -> Size - {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "E" _N_ _N_ #-} printLabeledCodes :: PprStyle -> [AlphaInstr] -> CSeq - {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} pv :: Reg - {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} ra :: Reg - {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [26#] _N_ #-} reservedRegs :: [Int] - {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} sp :: Reg - {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [30#] _N_ #-} stgRegMap :: MagicId -> Labda Reg - {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} strImmLab :: [Char] -> Imm - {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} v0 :: Reg - {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} zero :: Reg - {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [31#] _N_ #-} instance MachineCode AlphaInstr - {-# GHC_PRAGMA _M_ AlphaCode {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 6 _!_ _TUP_5 [(AlphaInstr -> RegUsage), (AlphaInstr -> RegLiveness -> RegLiveness), (AlphaInstr -> (Reg -> Reg) -> AlphaInstr), (Reg -> Reg -> OrdList AlphaInstr), (Reg -> Reg -> OrdList AlphaInstr)] [_CONSTM_ MachineCode regUsage (AlphaInstr), _CONSTM_ MachineCode regLiveness (AlphaInstr), _CONSTM_ MachineCode patchRegs (AlphaInstr), _CONSTM_ MachineCode spillReg (AlphaInstr), _CONSTM_ MachineCode loadReg (AlphaInstr)] _N_ - regUsage = _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_, - regLiveness = _A_ 2 _U_ 11 _N_ _S_ "SU(LU(LL))" {_A_ 4 _U_ 1222 _N_ _N_ _N_ _N_} _N_ _N_, - patchRegs = _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_, - spillReg = _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_, - loadReg = _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-} instance MachineRegisters AlphaRegs - {-# GHC_PRAGMA _M_ AlphaCode {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 7 _!_ _TUP_6 [([Int] -> AlphaRegs), (PrimKind -> AlphaRegs -> [Int]), (AlphaRegs -> Int# -> AlphaRegs), (AlphaRegs -> [Int] -> AlphaRegs), (AlphaRegs -> Int# -> AlphaRegs), (AlphaRegs -> [Int] -> AlphaRegs)] [_CONSTM_ MachineRegisters mkMRegs (AlphaRegs), _CONSTM_ MachineRegisters possibleMRegs (AlphaRegs), _CONSTM_ MachineRegisters useMReg (AlphaRegs), _CONSTM_ MachineRegisters useMRegs (AlphaRegs), _CONSTM_ MachineRegisters freeMReg (AlphaRegs), _CONSTM_ MachineRegisters freeMRegs (AlphaRegs)] _N_ - mkMRegs = _A_ 1 _U_ 1 _N_ _N_ _N_ _N_, - possibleMRegs = _A_ 2 _U_ 11 _N_ _S_ "EU(LL)" {_A_ 3 _U_ 111 _N_ _N_ _N_ _N_} _N_ _N_, - useMReg = _A_ 2 _U_ 12 _N_ _S_ "U(LL)P" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_, - useMRegs = _A_ 2 _U_ 11 _N_ _S_ "U(LL)L" {_A_ 3 _U_ 111 _N_ _N_ _N_ _N_} _N_ _N_, - freeMReg = _A_ 2 _U_ 12 _N_ _S_ "U(LL)P" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_, - freeMRegs = _A_ 2 _U_ 11 _N_ _S_ "U(LL)L" {_A_ 3 _U_ 111 _N_ _N_ _N_ _N_} _N_ _N_ #-} diff --git a/ghc/compiler/nativeGen/AlphaCode.lhs b/ghc/compiler/nativeGen/AlphaCode.lhs index 91d3aca2f3..5d7f4b2a3f 100644 --- a/ghc/compiler/nativeGen/AlphaCode.lhs +++ b/ghc/compiler/nativeGen/AlphaCode.lhs @@ -212,7 +212,7 @@ data AlphaInstr = | FUNEND CLabel | COMMENT FAST_STRING | SEGMENT CodeSegment - | ASCII Bool String + | ASCII Bool String -- needs backslash conversion? | DATA Size [Imm] type AlphaCode = OrdList AlphaInstr @@ -1120,7 +1120,7 @@ baseRegOffset SuB = OFFSET_SuB baseRegOffset Hp = OFFSET_Hp baseRegOffset HpLim = OFFSET_HpLim baseRegOffset LivenessReg = OFFSET_Liveness -baseRegOffset ActivityReg = OFFSET_Activity +--baseRegOffset ActivityReg = OFFSET_Activity #ifdef DEBUG baseRegOffset BaseReg = panic "baseRegOffset:BaseReg" baseRegOffset StdUpdRetVecReg = panic "baseRegOffset:StgUpdRetVecReg" @@ -1206,7 +1206,7 @@ callerSaves HpLim = True callerSaves LivenessReg = True #endif #ifdef CALLER_SAVES_Activity -callerSaves ActivityReg = True +--callerSaves ActivityReg = True #endif #ifdef CALLER_SAVES_StdUpdRetVec callerSaves StdUpdRetVecReg = True @@ -1293,7 +1293,7 @@ stgRegMap HpLim = Just (FixedReg ILIT(REG_HpLim)) stgRegMap LivenessReg = Just (FixedReg ILIT(REG_Liveness)) #endif #ifdef REG_Activity -stgRegMap ActivityReg = Just (FixedReg ILIT(REG_Activity)) +--stgRegMap ActivityReg = Just (FixedReg ILIT(REG_Activity)) #endif #ifdef REG_StdUpdRetVec stgRegMap StdUpdRetVecReg = Just (FixedReg ILIT(REG_StdUpdRetVec)) @@ -1397,7 +1397,7 @@ freeReg ILIT(REG_HpLim) = _FALSE_ freeReg ILIT(REG_Liveness) = _FALSE_ #endif #ifdef REG_Activity -freeReg ILIT(REG_Activity) = _FALSE_ +--freeReg ILIT(REG_Activity) = _FALSE_ #endif #ifdef REG_StdUpdRetVec freeReg ILIT(REG_StdUpdRetVec) = _FALSE_ diff --git a/ghc/compiler/nativeGen/AlphaDesc.hi b/ghc/compiler/nativeGen/AlphaDesc.hi index 9245388aa4..750e28eb31 100644 --- a/ghc/compiler/nativeGen/AlphaDesc.hi +++ b/ghc/compiler/nativeGen/AlphaDesc.hi @@ -11,14 +11,14 @@ import Pretty(PprStyle) import PrimKind(PrimKind) import PrimOps(PrimOp) import SMRep(SMRep, SMSpecRepKind, SMUpdateKind) +import SplitUniq(SplitUniqSupply) import Stix(CodeSegment, StixReg, StixTree) -data MagicId {-# GHC_PRAGMA BaseReg | StkOReg | VanillaReg PrimKind Int# | FloatReg Int# | DoubleReg Int# | TagReg | RetReg | SpA | SuA | SpB | SuB | Hp | HpLim | LivenessReg | ActivityReg | StdUpdRetVecReg | StkStubReg | CurCostCentre | VoidReg #-} -data SwitchResult {-# GHC_PRAGMA SwBool Bool | SwString [Char] | SwInt Int #-} -data RegLoc {-# GHC_PRAGMA Save StixTree | Always StixTree #-} -data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-} -data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-} -data SMRep {-# GHC_PRAGMA StaticRep Int Int | SpecialisedRep SMSpecRepKind Int Int SMUpdateKind | GenericRep Int Int SMUpdateKind | BigTupleRep Int | DataRep Int | DynamicRep | BlackHoleRep | PhantomRep | MuTupleRep Int #-} -data StixTree {-# GHC_PRAGMA StSegment CodeSegment | StInt Integer | StDouble (Ratio Integer) | StString _PackedString | StLitLbl CSeq | StLitLit _PackedString | StCLbl CLabel | StReg StixReg | StIndex PrimKind StixTree StixTree | StInd PrimKind StixTree | StAssign PrimKind StixTree StixTree | StLabel CLabel | StFunBegin CLabel | StFunEnd CLabel | StJump StixTree | StFallThrough CLabel | StCondJump CLabel StixTree | StData PrimKind [StixTree] | StPrim PrimOp [StixTree] | StCall _PackedString PrimKind [StixTree] | StComment _PackedString #-} -mkAlpha :: (GlobalSwitch -> SwitchResult) -> Target - {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +data MagicId +data SwitchResult +data RegLoc +data PprStyle +data PrimKind +data SMRep +data StixTree +mkAlpha :: (GlobalSwitch -> SwitchResult) -> (Target, PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq, Bool, [Char] -> [Char]) diff --git a/ghc/compiler/nativeGen/AlphaDesc.lhs b/ghc/compiler/nativeGen/AlphaDesc.lhs index e9ea4d067b..2c0eeb544e 100644 --- a/ghc/compiler/nativeGen/AlphaDesc.lhs +++ b/ghc/compiler/nativeGen/AlphaDesc.lhs @@ -122,7 +122,7 @@ because some are reloaded from constants. \begin{code} vsaves switches vols = - map save ((filter callerSaves) ([BaseReg,SpA,SuA,SpB,SuB,Hp,HpLim,RetReg,ActivityReg] ++ vols)) + map save ((filter callerSaves) ([BaseReg,SpA,SuA,SpB,SuB,Hp,HpLim,RetReg{-,ActivityReg-}] ++ vols)) where save x = StAssign (kindFromMagicId x) loc reg where reg = StReg (StixMagicId x) @@ -132,7 +132,7 @@ vsaves switches vols = vrests switches vols = map restore ((filter callerSaves) - ([BaseReg,SpA,SuA,SpB,SuB,Hp,HpLim,RetReg,ActivityReg,StkStubReg,StdUpdRetVecReg] ++ vols)) + ([BaseReg,SpA,SuA,SpB,SuB,Hp,HpLim,RetReg,{-ActivityReg,-}StkStubReg,StdUpdRetVecReg] ++ vols)) where restore x = StAssign (kindFromMagicId x) reg loc where reg = StReg (StixMagicId x) @@ -172,10 +172,15 @@ Setting up a alpha target. \begin{code} -mkAlpha :: (GlobalSwitch -> SwitchResult) -> Target +mkAlpha :: (GlobalSwitch -> SwitchResult) + -> (Target, + (PprStyle -> [[StixTree]] -> SUniqSM Unpretty), -- codeGen + Bool, -- underscore + (String -> String)) -- fmtAsmLbl mkAlpha switches = - let fhs' = fhs switches + let + fhs' = fhs switches vhs' = vhs switches alphaReg' = alphaReg switches vsaves' = vsaves switches @@ -189,12 +194,13 @@ mkAlpha switches = dhs' = dhs switches ps = genPrimCode target mc = genMacroCode target - hc = doHeapCheck target - target = mkTarget switches fhs' vhs' alphaReg' id size vsaves' vrests' - hprel as as' csz isz mhs' dhs' ps mc hc - alphaCodeGen False mungeLabel - in target - + hc = doHeapCheck --UNUSED NOW: target + target = mkTarget {-switches-} fhs' vhs' alphaReg' {-id-} size + hprel as as' + (vsaves', vrests', csz, isz, mhs', dhs', ps, mc, hc) + {-alphaCodeGen False mungeLabel-} + in + (target, alphaCodeGen, False, mungeLabel) \end{code} The alpha assembler likes temporary labels to look like \tr{$L123} diff --git a/ghc/compiler/nativeGen/AlphaGen.hi b/ghc/compiler/nativeGen/AlphaGen.hi index fb46055d5a..9d24768163 100644 --- a/ghc/compiler/nativeGen/AlphaGen.hi +++ b/ghc/compiler/nativeGen/AlphaGen.hi @@ -10,9 +10,8 @@ import PrimKind(PrimKind) import PrimOps(PrimOp) import SplitUniq(SplitUniqSupply) import Stix(CodeSegment, StixReg, StixTree) -data CSeq {-# GHC_PRAGMA CNil | CAppend CSeq CSeq | CIndent Int CSeq | CNewline | CStr [Char] | CCh Char | CInt Int | CPStr _PackedString #-} -data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-} -data StixTree {-# GHC_PRAGMA StSegment CodeSegment | StInt Integer | StDouble (Ratio Integer) | StString _PackedString | StLitLbl CSeq | StLitLit _PackedString | StCLbl CLabel | StReg StixReg | StIndex PrimKind StixTree StixTree | StInd PrimKind StixTree | StAssign PrimKind StixTree StixTree | StLabel CLabel | StFunBegin CLabel | StFunEnd CLabel | StJump StixTree | StFallThrough CLabel | StCondJump CLabel StixTree | StData PrimKind [StixTree] | StPrim PrimOp [StixTree] | StCall _PackedString PrimKind [StixTree] | StComment _PackedString #-} +data CSeq +data PprStyle +data StixTree alphaCodeGen :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq - {-# GHC_PRAGMA _A_ 2 _U_ 211 _N_ _S_ "LS" _N_ _N_ #-} diff --git a/ghc/compiler/nativeGen/AlphaGen.lhs b/ghc/compiler/nativeGen/AlphaGen.lhs index 3eb5a04dba..533a5184db 100644 --- a/ghc/compiler/nativeGen/AlphaGen.lhs +++ b/ghc/compiler/nativeGen/AlphaGen.lhs @@ -294,7 +294,6 @@ getReg (StPrim primop args) = IntSubOp -> trivialCode (SUB Q False) args IntMulOp -> trivialCode (MUL Q False) args IntQuotOp -> trivialCode (DIV Q False) args - IntDivOp -> call SLIT("stg_div") IntKind IntRemOp -> trivialCode (REM Q False) args IntNegOp -> trivialUCode (NEG Q False) args IntAbsOp -> trivialUCode (ABS Q) args diff --git a/ghc/compiler/nativeGen/AsmCodeGen.hi b/ghc/compiler/nativeGen/AsmCodeGen.hi index 9aedf3a208..4119e7ece5 100644 --- a/ghc/compiler/nativeGen/AsmCodeGen.hi +++ b/ghc/compiler/nativeGen/AsmCodeGen.hi @@ -1,24 +1,14 @@ {-# GHC_PRAGMA INTERFACE VERSION 5 #-} interface AsmCodeGen where -import AbsCSyn(AbstractC, CAddrMode, CStmtMacro, MagicId, RegRelative, ReturnInfo) -import BasicLit(BasicLit) -import CLabelInfo(CLabel) -import ClosureInfo(ClosureInfo) +import AbsCSyn(AbstractC) import CmdLineOpts(GlobalSwitch, SwitchResult) -import CostCentre(CostCentre) -import Maybes(Labda) -import PreludePS(_PackedString) -import PrimOps(PrimOp) import SplitUniq(SUniqSM(..), SplitUniqSupply) import Stdio(_FILE) -data AbstractC {-# GHC_PRAGMA AbsCNop | AbsCStmts AbstractC AbstractC | CAssign CAddrMode CAddrMode | CJump CAddrMode | CFallThrough CAddrMode | CReturn CAddrMode ReturnInfo | CSwitch CAddrMode [(BasicLit, AbstractC)] AbstractC | CCodeBlock CLabel AbstractC | CInitHdr ClosureInfo RegRelative CAddrMode Bool | COpStmt [CAddrMode] PrimOp [CAddrMode] Int [MagicId] | CSimultaneous AbstractC | CMacroStmt CStmtMacro [CAddrMode] | CCallProfCtrMacro _PackedString [CAddrMode] | CCallProfCCMacro _PackedString [CAddrMode] | CStaticClosure CLabel ClosureInfo CAddrMode [CAddrMode] | CClosureInfoAndCode ClosureInfo AbstractC (Labda AbstractC) CAddrMode [Char] | CRetVector CLabel [Labda CAddrMode] AbstractC | CRetUnVector CLabel CAddrMode | CFlatRetVector CLabel [CAddrMode] | CCostCentreDecl Bool CostCentre | CClosureUpdInfo AbstractC | CSplitMarker #-} -data GlobalSwitch - {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-} -data SwitchResult {-# GHC_PRAGMA SwBool Bool | SwString [Char] | SwInt Int #-} +data AbstractC +data GlobalSwitch +data SwitchResult type SUniqSM a = SplitUniqSupply -> a -data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-} +data SplitUniqSupply dumpRealAsm :: (GlobalSwitch -> SwitchResult) -> AbstractC -> SplitUniqSupply -> [Char] - {-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _S_ "SLU(ALL)" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-} writeRealAsm :: (GlobalSwitch -> SwitchResult) -> _FILE -> AbstractC -> SplitUniqSupply -> _State _RealWorld -> ((), _State _RealWorld) - {-# GHC_PRAGMA _A_ 5 _U_ 21212 _N_ _S_ "SU(P)LU(ALL)L" {_A_ 5 _U_ 22212 _N_ _N_ _N_ _N_} _N_ _N_ #-} diff --git a/ghc/compiler/nativeGen/AsmCodeGen.lhs b/ghc/compiler/nativeGen/AsmCodeGen.lhs index bbb4cc9ae9..47bc965c8f 100644 --- a/ghc/compiler/nativeGen/AsmCodeGen.lhs +++ b/ghc/compiler/nativeGen/AsmCodeGen.lhs @@ -28,13 +28,15 @@ import CmdLineOpts ( GlobalSwitch(..), stringSwitchSet, switchIsOn, SwitchResul import MachDesc import Maybes ( Maybe(..) ) import Outputable -#if alpha_dec_osf1_TARGET +#if alpha_TARGET_ARCH import AlphaDesc ( mkAlpha ) -#else +#endif +#if i386_TARGET_ARCH +import I386Desc ( mkI386 ) +#endif #if sparc_TARGET_ARCH import SparcDesc ( mkSparc ) #endif -#endif import Stix import SplitUniq import Unique @@ -141,21 +143,25 @@ code flags absC = let stix = map (map (genericOpt target)) treelists in - codeGen target sty stix + codeGen {-target-} sty stix where - sty = PprForAsm (switchIsOn flags) (underscore target) (fmtAsmLbl target) + sty = PprForAsm (switchIsOn flags) (underscore {-target-}) (fmtAsmLbl {-target-}) - target = case stringSwitchSet flags AsmTarget of + (target, codeGen, underscore, fmtAsmLbl) + = case stringSwitchSet flags AsmTarget of #if ! OMIT_NATIVE_CODEGEN -#if sparc_sun_sunos4_TARGET +# if alpha_TARGET_ARCH + Just _ {-???"alpha-dec-osf1"-} -> mkAlpha flags +# endif +# if i386_TARGET_ARCH + Just _ {-???"i386_unknown_linuxaout"-} -> mkI386 True flags +# endif +# if sparc_sun_sunos4_TARGET Just _ {-???"sparc-sun-sunos4"-} -> mkSparc True flags -#endif -#if sparc_sun_solaris2_TARGET +# endif +# if sparc_sun_solaris2_TARGET Just _ {-???"sparc-sun-solaris2"-} -> mkSparc False flags -#endif -#if alpha_TARGET_ARCH - Just _ {-???"alpha-dec-osf1"-} -> mkAlpha flags -#endif +# endif #endif _ -> error ("ERROR:Trying to generate assembly language for an unsupported architecture\n"++ @@ -190,8 +196,10 @@ genericOpt For most nodes, just optimize the children. \begin{code} +-- hacking with Uncle Will: +#define target_STRICT target@(Target _ _ _ _ _ _ _ _) -genericOpt target (StInd pk addr) = +genericOpt target_STRICT (StInd pk addr) = StInd pk (genericOpt target addr) genericOpt target (StAssign pk dst src) = @@ -275,7 +283,6 @@ primOpt op args@[StInt x, StInt y] = IntSubOp -> StInt (x - y) IntMulOp -> StInt (x * y) IntQuotOp -> StInt (x `quot` y) - IntDivOp -> StInt (x `div` y) IntRemOp -> StInt (x `rem` y) IntGtOp -> StInt (if x > y then 1 else 0) IntGeOp -> StInt (if x >= y then 1 else 0) @@ -321,7 +328,6 @@ primOpt op args@[x, y@(StInt 0)] = primOpt op args@[x, y@(StInt 1)] = case op of IntMulOp -> x - IntDivOp -> x IntQuotOp -> x IntRemOp -> StInt 0 _ -> StPrim op args diff --git a/ghc/compiler/nativeGen/AsmRegAlloc.hi b/ghc/compiler/nativeGen/AsmRegAlloc.hi index 2c1bed2ca9..4959627422 100644 --- a/ghc/compiler/nativeGen/AsmRegAlloc.hi +++ b/ghc/compiler/nativeGen/AsmRegAlloc.hi @@ -3,92 +3,42 @@ interface AsmRegAlloc where import CLabelInfo(CLabel) import FiniteMap(FiniteMap) import OrdList(OrdList) -import Outputable(NamedThing) +import Outputable(NamedThing, Outputable) import PrimKind(PrimKind) import UniqFM(UniqFM) import UniqSet(UniqSet(..)) import Unique(Unique) class MachineCode a where regUsage :: a -> RegUsage - {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "U(SAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> RegUsage) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> RegUsage, u0 -> RegLiveness -> RegLiveness, u0 -> (Reg -> Reg) -> u0, Reg -> Reg -> OrdList u0, Reg -> Reg -> OrdList u0)) -> case u1 of { _ALG_ _TUP_5 (u2 :: u0 -> RegUsage) (u3 :: u0 -> RegLiveness -> RegLiveness) (u4 :: u0 -> (Reg -> Reg) -> u0) (u5 :: Reg -> Reg -> OrdList u0) (u6 :: Reg -> Reg -> OrdList u0) -> u2; _NO_DEFLT_ } _N_ - {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{MachineCode u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> RegUsage) } [ _NOREP_S_ "%DAsmRegAlloc.MachineCode.regUsage\"", u2 ] _N_ #-} regLiveness :: a -> RegLiveness -> RegLiveness - {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 122 _N_ _S_ "U(ASAAA)" {_A_ 1 _U_ 122 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> RegLiveness -> RegLiveness) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> RegUsage, u0 -> RegLiveness -> RegLiveness, u0 -> (Reg -> Reg) -> u0, Reg -> Reg -> OrdList u0, Reg -> Reg -> OrdList u0)) -> case u1 of { _ALG_ _TUP_5 (u2 :: u0 -> RegUsage) (u3 :: u0 -> RegLiveness -> RegLiveness) (u4 :: u0 -> (Reg -> Reg) -> u0) (u5 :: Reg -> Reg -> OrdList u0) (u6 :: Reg -> Reg -> OrdList u0) -> u3; _NO_DEFLT_ } _N_ - {-defm-} _A_ 3 _U_ 022 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 3 XXX 4 _/\_ u0 -> \ (u1 :: {{MachineCode u0}}) (u2 :: u0) (u3 :: RegLiveness) -> _APP_ _TYAPP_ patError# { (u0 -> RegLiveness -> RegLiveness) } [ _NOREP_S_ "%DAsmRegAlloc.MachineCode.regLiveness\"", u2, u3 ] _N_ #-} patchRegs :: a -> (Reg -> Reg) -> a - {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 122 _N_ _S_ "U(AASAA)" {_A_ 1 _U_ 122 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> (Reg -> Reg) -> u0) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> RegUsage, u0 -> RegLiveness -> RegLiveness, u0 -> (Reg -> Reg) -> u0, Reg -> Reg -> OrdList u0, Reg -> Reg -> OrdList u0)) -> case u1 of { _ALG_ _TUP_5 (u2 :: u0 -> RegUsage) (u3 :: u0 -> RegLiveness -> RegLiveness) (u4 :: u0 -> (Reg -> Reg) -> u0) (u5 :: Reg -> Reg -> OrdList u0) (u6 :: Reg -> Reg -> OrdList u0) -> u4; _NO_DEFLT_ } _N_ - {-defm-} _A_ 3 _U_ 022 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 3 XXX 4 _/\_ u0 -> \ (u1 :: {{MachineCode u0}}) (u2 :: u0) (u3 :: Reg -> Reg) -> _APP_ _TYAPP_ patError# { (u0 -> (Reg -> Reg) -> u0) } [ _NOREP_S_ "%DAsmRegAlloc.MachineCode.patchRegs\"", u2, u3 ] _N_ #-} spillReg :: Reg -> Reg -> OrdList a - {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 122 _N_ _S_ "U(AAASA)" {_A_ 1 _U_ 122 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: Reg -> Reg -> OrdList u0) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> RegUsage, u0 -> RegLiveness -> RegLiveness, u0 -> (Reg -> Reg) -> u0, Reg -> Reg -> OrdList u0, Reg -> Reg -> OrdList u0)) -> case u1 of { _ALG_ _TUP_5 (u2 :: u0 -> RegUsage) (u3 :: u0 -> RegLiveness -> RegLiveness) (u4 :: u0 -> (Reg -> Reg) -> u0) (u5 :: Reg -> Reg -> OrdList u0) (u6 :: Reg -> Reg -> OrdList u0) -> u5; _NO_DEFLT_ } _N_ - {-defm-} _A_ 3 _U_ 022 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 3 XXX 4 _/\_ u0 -> \ (u1 :: {{MachineCode u0}}) (u2 :: Reg) (u3 :: Reg) -> _APP_ _TYAPP_ patError# { (Reg -> Reg -> OrdList u0) } [ _NOREP_S_ "%DAsmRegAlloc.MachineCode.spillReg\"", u2, u3 ] _N_ #-} loadReg :: Reg -> Reg -> OrdList a - {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 122 _N_ _S_ "U(AAAAS)" {_A_ 1 _U_ 122 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: Reg -> Reg -> OrdList u0) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> RegUsage, u0 -> RegLiveness -> RegLiveness, u0 -> (Reg -> Reg) -> u0, Reg -> Reg -> OrdList u0, Reg -> Reg -> OrdList u0)) -> case u1 of { _ALG_ _TUP_5 (u2 :: u0 -> RegUsage) (u3 :: u0 -> RegLiveness -> RegLiveness) (u4 :: u0 -> (Reg -> Reg) -> u0) (u5 :: Reg -> Reg -> OrdList u0) (u6 :: Reg -> Reg -> OrdList u0) -> u6; _NO_DEFLT_ } _N_ - {-defm-} _A_ 3 _U_ 022 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 3 XXX 4 _/\_ u0 -> \ (u1 :: {{MachineCode u0}}) (u2 :: Reg) (u3 :: Reg) -> _APP_ _TYAPP_ patError# { (Reg -> Reg -> OrdList u0) } [ _NOREP_S_ "%DAsmRegAlloc.MachineCode.loadReg\"", u2, u3 ] _N_ #-} class MachineRegisters a where mkMRegs :: [Int] -> a - {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "U(SAAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: [Int] -> u0) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: ([Int] -> u0, PrimKind -> u0 -> [Int], u0 -> Int# -> u0, u0 -> [Int] -> u0, u0 -> Int# -> u0, u0 -> [Int] -> u0)) -> case u1 of { _ALG_ _TUP_6 (u2 :: [Int] -> u0) (u3 :: PrimKind -> u0 -> [Int]) (u4 :: u0 -> Int# -> u0) (u5 :: u0 -> [Int] -> u0) (u6 :: u0 -> Int# -> u0) (u7 :: u0 -> [Int] -> u0) -> u2; _NO_DEFLT_ } _N_ - {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{MachineRegisters u0}}) (u2 :: [Int]) -> _APP_ _TYAPP_ patError# { ([Int] -> u0) } [ _NOREP_S_ "%DAsmRegAlloc.MachineRegisters.mkMRegs\"", u2 ] _N_ #-} possibleMRegs :: PrimKind -> a -> [Int] - {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 122 _N_ _S_ "U(ASAAAA)" {_A_ 1 _U_ 122 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: PrimKind -> u0 -> [Int]) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: ([Int] -> u0, PrimKind -> u0 -> [Int], u0 -> Int# -> u0, u0 -> [Int] -> u0, u0 -> Int# -> u0, u0 -> [Int] -> u0)) -> case u1 of { _ALG_ _TUP_6 (u2 :: [Int] -> u0) (u3 :: PrimKind -> u0 -> [Int]) (u4 :: u0 -> Int# -> u0) (u5 :: u0 -> [Int] -> u0) (u6 :: u0 -> Int# -> u0) (u7 :: u0 -> [Int] -> u0) -> u3; _NO_DEFLT_ } _N_ - {-defm-} _A_ 3 _U_ 022 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 3 XXX 4 _/\_ u0 -> \ (u1 :: {{MachineRegisters u0}}) (u2 :: PrimKind) (u3 :: u0) -> _APP_ _TYAPP_ patError# { (PrimKind -> u0 -> [Int]) } [ _NOREP_S_ "%DAsmRegAlloc.MachineRegisters.possibleMRegs\"", u2, u3 ] _N_ #-} useMReg :: a -> Int# -> a - {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 122 _N_ _S_ "U(AASAAA)" {_A_ 1 _U_ 122 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> Int# -> u0) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: ([Int] -> u0, PrimKind -> u0 -> [Int], u0 -> Int# -> u0, u0 -> [Int] -> u0, u0 -> Int# -> u0, u0 -> [Int] -> u0)) -> case u1 of { _ALG_ _TUP_6 (u2 :: [Int] -> u0) (u3 :: PrimKind -> u0 -> [Int]) (u4 :: u0 -> Int# -> u0) (u5 :: u0 -> [Int] -> u0) (u6 :: u0 -> Int# -> u0) (u7 :: u0 -> [Int] -> u0) -> u4; _NO_DEFLT_ } _N_ - {-defm-} _A_ 3 _U_ 022 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 3 XXX 4 _/\_ u0 -> \ (u1 :: {{MachineRegisters u0}}) (u2 :: u0) (u3 :: Int#) -> _APP_ _TYAPP_ patError# { (u0 -> Int# -> u0) } [ _NOREP_S_ "%DAsmRegAlloc.MachineRegisters.useMReg\"", u2, u3 ] _N_ #-} useMRegs :: a -> [Int] -> a - {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 122 _N_ _S_ "U(AAASAA)" {_A_ 1 _U_ 122 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> [Int] -> u0) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: ([Int] -> u0, PrimKind -> u0 -> [Int], u0 -> Int# -> u0, u0 -> [Int] -> u0, u0 -> Int# -> u0, u0 -> [Int] -> u0)) -> case u1 of { _ALG_ _TUP_6 (u2 :: [Int] -> u0) (u3 :: PrimKind -> u0 -> [Int]) (u4 :: u0 -> Int# -> u0) (u5 :: u0 -> [Int] -> u0) (u6 :: u0 -> Int# -> u0) (u7 :: u0 -> [Int] -> u0) -> u5; _NO_DEFLT_ } _N_ - {-defm-} _A_ 3 _U_ 022 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 3 XXX 4 _/\_ u0 -> \ (u1 :: {{MachineRegisters u0}}) (u2 :: u0) (u3 :: [Int]) -> _APP_ _TYAPP_ patError# { (u0 -> [Int] -> u0) } [ _NOREP_S_ "%DAsmRegAlloc.MachineRegisters.useMRegs\"", u2, u3 ] _N_ #-} freeMReg :: a -> Int# -> a - {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 122 _N_ _S_ "U(AAAASA)" {_A_ 1 _U_ 122 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> Int# -> u0) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: ([Int] -> u0, PrimKind -> u0 -> [Int], u0 -> Int# -> u0, u0 -> [Int] -> u0, u0 -> Int# -> u0, u0 -> [Int] -> u0)) -> case u1 of { _ALG_ _TUP_6 (u2 :: [Int] -> u0) (u3 :: PrimKind -> u0 -> [Int]) (u4 :: u0 -> Int# -> u0) (u5 :: u0 -> [Int] -> u0) (u6 :: u0 -> Int# -> u0) (u7 :: u0 -> [Int] -> u0) -> u6; _NO_DEFLT_ } _N_ - {-defm-} _A_ 3 _U_ 022 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 3 XXX 4 _/\_ u0 -> \ (u1 :: {{MachineRegisters u0}}) (u2 :: u0) (u3 :: Int#) -> _APP_ _TYAPP_ patError# { (u0 -> Int# -> u0) } [ _NOREP_S_ "%DAsmRegAlloc.MachineRegisters.freeMReg\"", u2, u3 ] _N_ #-} freeMRegs :: a -> [Int] -> a - {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 122 _N_ _S_ "U(AAAAAS)" {_A_ 1 _U_ 122 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> [Int] -> u0) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: ([Int] -> u0, PrimKind -> u0 -> [Int], u0 -> Int# -> u0, u0 -> [Int] -> u0, u0 -> Int# -> u0, u0 -> [Int] -> u0)) -> case u1 of { _ALG_ _TUP_6 (u2 :: [Int] -> u0) (u3 :: PrimKind -> u0 -> [Int]) (u4 :: u0 -> Int# -> u0) (u5 :: u0 -> [Int] -> u0) (u6 :: u0 -> Int# -> u0) (u7 :: u0 -> [Int] -> u0) -> u7; _NO_DEFLT_ } _N_ - {-defm-} _A_ 3 _U_ 022 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 3 XXX 4 _/\_ u0 -> \ (u1 :: {{MachineRegisters u0}}) (u2 :: u0) (u3 :: [Int]) -> _APP_ _TYAPP_ patError# { (u0 -> [Int] -> u0) } [ _NOREP_S_ "%DAsmRegAlloc.MachineRegisters.freeMRegs\"", u2, u3 ] _N_ #-} data CLabel -data FiniteMap a b {-# GHC_PRAGMA EmptyFM | Branch a b Int# (FiniteMap a b) (FiniteMap a b) #-} +data FiniteMap a b data FutureLive = FL (UniqFM Reg) (FiniteMap CLabel (UniqFM Reg)) -data OrdList a {-# GHC_PRAGMA SeqList (OrdList a) (OrdList a) | ParList (OrdList a) (OrdList a) | OrdObj a | NoObj #-} -data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-} +data OrdList a +data PrimKind data Reg = FixedReg Int# | MappedReg Int# | MemoryReg Int PrimKind | UnmappedReg Unique PrimKind data RegLiveness = RL (UniqFM Reg) FutureLive data RegUsage = RU (UniqFM Reg) (UniqFM Reg) -data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-} +data UniqFM a type UniqSet a = UniqFM a -data Unique {-# GHC_PRAGMA MkUnique Int# #-} +data Unique extractMappedRegNos :: [Reg] -> [Int] - {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} mkReg :: Unique -> PrimKind -> Reg - {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Unique) (u1 :: PrimKind) -> _!_ _ORIG_ AsmRegAlloc UnmappedReg [] [u0, u1] _N_ #-} +runHairyRegAllocate :: (MachineRegisters a, MachineCode b) => a -> [Int] -> OrdList b -> [b] runRegAllocate :: (MachineRegisters a, MachineCode b) => a -> [Int] -> OrdList b -> [b] - {-# GHC_PRAGMA _A_ 5 _U_ 22221 _N_ _S_ "LLLLS" _N_ _SPECIALISE_ [ AlphaRegs, AlphaInstr ] 2 { _A_ 0 _U_ 221 _N_ _N_ _N_ _N_ } #-} instance Eq Reg - {-# GHC_PRAGMA _M_ AsmRegAlloc {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Reg -> Reg -> Bool), (Reg -> Reg -> Bool)] [_CONSTM_ Eq (==) (Reg), _CONSTM_ Eq (/=) (Reg)] _N_ - (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, - (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} instance Ord Reg - {-# GHC_PRAGMA _M_ AsmRegAlloc {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Reg}}, (Reg -> Reg -> Bool), (Reg -> Reg -> Bool), (Reg -> Reg -> Bool), (Reg -> Reg -> Bool), (Reg -> Reg -> Reg), (Reg -> Reg -> Reg), (Reg -> Reg -> _CMP_TAG)] [_DFUN_ Eq (Reg), _CONSTM_ Ord (<) (Reg), _CONSTM_ Ord (<=) (Reg), _CONSTM_ Ord (>=) (Reg), _CONSTM_ Ord (>) (Reg), _CONSTM_ Ord max (Reg), _CONSTM_ Ord min (Reg), _CONSTM_ Ord _tagCmp (Reg)] _N_ - (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, - (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, - (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, - (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, - max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, - min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, - _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} instance NamedThing Reg - {-# GHC_PRAGMA _M_ AsmRegAlloc {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(Reg -> ExportFlag), (Reg -> Bool), (Reg -> (_PackedString, _PackedString)), (Reg -> _PackedString), (Reg -> [_PackedString]), (Reg -> SrcLoc), (Reg -> Unique), (Reg -> Bool), (Reg -> UniType), (Reg -> Bool)] [_CONSTM_ NamedThing getExportFlag (Reg), _CONSTM_ NamedThing isLocallyDefined (Reg), _CONSTM_ NamedThing getOrigName (Reg), _CONSTM_ NamedThing getOccurrenceName (Reg), _CONSTM_ NamedThing getInformingModules (Reg), _CONSTM_ NamedThing getSrcLoc (Reg), _CONSTM_ NamedThing getTheUnique (Reg), _CONSTM_ NamedThing hasType (Reg), _CONSTM_ NamedThing getType (Reg), _CONSTM_ NamedThing fromPreludeCore (Reg)] _N_ - getExportFlag = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Reg) -> _APP_ _TYAPP_ patError# { (Reg -> ExportFlag) } [ _NOREP_S_ "%DOutputable.NamedThing.getExportFlag\"", u0 ] _N_, - isLocallyDefined = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Reg) -> _APP_ _TYAPP_ patError# { (Reg -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.isLocallyDefined\"", u0 ] _N_, - getOrigName = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Reg) -> _APP_ _TYAPP_ patError# { (Reg -> (_PackedString, _PackedString)) } [ _NOREP_S_ "%DOutputable.NamedThing.getOrigName\"", u0 ] _N_, - getOccurrenceName = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Reg) -> _APP_ _TYAPP_ patError# { (Reg -> _PackedString) } [ _NOREP_S_ "%DOutputable.NamedThing.getOccurrenceName\"", u0 ] _N_, - getInformingModules = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Reg) -> _APP_ _TYAPP_ patError# { (Reg -> [_PackedString]) } [ _NOREP_S_ "%DOutputable.NamedThing.getInformingModules\"", u0 ] _N_, - getSrcLoc = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Reg) -> _APP_ _TYAPP_ patError# { (Reg -> SrcLoc) } [ _NOREP_S_ "%DOutputable.NamedThing.getSrcLoc\"", u0 ] _N_, - getTheUnique = _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_, - hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Reg) -> _APP_ _TYAPP_ patError# { (Reg -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u0 ] _N_, - getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Reg) -> _APP_ _TYAPP_ patError# { (Reg -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u0 ] _N_, - fromPreludeCore = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Reg) -> _APP_ _TYAPP_ patError# { (Reg -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.fromPreludeCore\"", u0 ] _N_ #-} +instance Outputable Reg instance Text Reg - {-# GHC_PRAGMA _M_ AsmRegAlloc {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Reg, [Char])]), (Int -> Reg -> [Char] -> [Char]), ([Char] -> [([Reg], [Char])]), ([Reg] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Reg), _CONSTM_ Text showsPrec (Reg), _CONSTM_ Text readList (Reg), _CONSTM_ Text showList (Reg)] _N_ - readsPrec = _A_ 2 _U_ 22 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 2 XX 4 \ (u0 :: Int) (u1 :: [Char]) -> _APP_ _TYAPP_ patError# { (Int -> [Char] -> [(Reg, [Char])]) } [ _NOREP_S_ "%DPreludeCore.Text.readsPrec\"", u0, u1 ] _N_, - showsPrec = _A_ 2 _U_ 012 _N_ _S_ "AS" {_A_ 1 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_, - readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_, - showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-} diff --git a/ghc/compiler/nativeGen/AsmRegAlloc.lhs b/ghc/compiler/nativeGen/AsmRegAlloc.lhs index 9d11e229b0..d71b00ec8d 100644 --- a/ghc/compiler/nativeGen/AsmRegAlloc.lhs +++ b/ghc/compiler/nativeGen/AsmRegAlloc.lhs @@ -11,7 +11,7 @@ module AsmRegAlloc ( FutureLive(..), RegLiveness(..), RegUsage(..), Reg(..), MachineRegisters(..), MachineCode(..), - mkReg, runRegAllocate, + mkReg, runRegAllocate, runHairyRegAllocate, extractMappedRegNos, -- And, for self-sufficiency @@ -35,20 +35,29 @@ import Util #if ! OMIT_NATIVE_CODEGEN -#if sparc_TARGET_ARCH -import SparcCode -- ( SparcInstr, SparcRegs ) -- for specializing +# if alpha_TARGET_ARCH +import AlphaCode -- ( AlphaInstr, AlphaRegs ) -- for specializing {-# SPECIALIZE - runRegAllocate :: SparcRegs -> [Int] -> (OrdList SparcInstr) -> [SparcInstr] + runRegAllocate :: AlphaRegs -> [Int] -> (OrdList AlphaInstr) -> [AlphaInstr] #-} -#endif -#if alpha_TARGET_ARCH -import AlphaCode -- ( AlphaInstr, AlphaRegs ) -- for specializing +# endif + +# if i386_TARGET_ARCH +import I386Code -- ( I386Instr, I386Regs ) -- for specializing {-# SPECIALIZE - runRegAllocate :: AlphaRegs -> [Int] -> (OrdList AlphaInstr) -> [AlphaInstr] + runRegAllocate :: I386Regs -> [Int] -> (OrdList I386Instr) -> [I386Instr] #-} -#endif +# endif + +# if sparc_TARGET_ARCH +import SparcCode -- ( SparcInstr, SparcRegs ) -- for specializing + +{-# SPECIALIZE + runRegAllocate :: SparcRegs -> [Int] -> (OrdList SparcInstr) -> [SparcInstr] + #-} +# endif #endif @@ -229,6 +238,17 @@ runRegAllocate regs reserve_regs instrs = simpleAlloc = simpleRegAlloc regs [] emptyFM flatInstrs hairyAlloc = hairyRegAlloc regs reserve_regs flatInstrs +runHairyRegAllocate -- use only hairy for i386! + :: (MachineRegisters a, MachineCode b) + => a + -> [Int] + -> (OrdList b) + -> [b] + +runHairyRegAllocate regs reserve_regs instrs + = hairyRegAlloc regs reserve_regs flatInstrs + where + flatInstrs = flattenOrdList instrs \end{code} Here is the simple register allocator. Just dole out registers until diff --git a/ghc/compiler/nativeGen/I386Code.hi b/ghc/compiler/nativeGen/I386Code.hi new file mode 100644 index 0000000000..e5fdf14b11 --- /dev/null +++ b/ghc/compiler/nativeGen/I386Code.hi @@ -0,0 +1,99 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface I386Code where +import AbsCSyn(MagicId) +import AsmRegAlloc(MachineCode, MachineRegisters, Reg) +import BitSet(BitSet) +import CLabelInfo(CLabel) +import CharSeq(CSeq) +import FiniteMap(FiniteMap) +import Maybes(Labda) +import OrdList(OrdList) +import PreludePS(_PackedString) +import Pretty(PprStyle) +import PrimKind(PrimKind) +import Stix(CodeSegment) +import UniqFM(UniqFM) +import UniqSet(UniqSet(..)) +import Unique(Unique) +data Addr = Addr (Labda Reg) (Labda (Reg, Int)) Imm | ImmAddr Imm Int +type Base = Labda Reg +data MagicId {-# GHC_PRAGMA BaseReg | StkOReg | VanillaReg PrimKind Int# | FloatReg Int# | DoubleReg Int# | TagReg | RetReg | SpA | SuA | SpB | SuB | Hp | HpLim | LivenessReg | ActivityReg | StdUpdRetVecReg | StkStubReg | CurCostCentre | VoidReg #-} +data Reg {-# GHC_PRAGMA FixedReg Int# | MappedReg Int# | MemoryReg Int PrimKind | UnmappedReg Unique PrimKind #-} +data BitSet {-# GHC_PRAGMA MkBS Word# #-} +data CLabel +data CSeq {-# GHC_PRAGMA CNil | CAppend CSeq CSeq | CIndent Int CSeq | CNewline | CStr [Char] | CCh Char | CInt Int | CPStr _PackedString #-} +data CodeSegment {-# GHC_PRAGMA DataSegment | TextSegment #-} +data Cond = ALWAYS | GEU | LU | EQ | GT | GE | GU | LT | LE | LEU | NE | NEG | POS +type Displacement = Imm +data FiniteMap a b {-# GHC_PRAGMA EmptyFM | Branch a b Int# (FiniteMap a b) (FiniteMap a b) #-} +type I386Code = OrdList I386Instr +data I386Instr + = MOV Size Operand Operand | MOVZX Size Operand Operand | MOVSX Size Operand Operand | LEA Size Operand Operand | ADD Size Operand Operand | SUB Size Operand Operand | IMUL Size Operand Operand | IDIV Size Operand | AND Size Operand Operand | OR Size Operand Operand | XOR Size Operand Operand | NOT Size Operand | NEGI Size Operand | SHL Size Operand Operand | SAR Size Operand Operand | SHR Size Operand Operand | NOP | SAHF | FABS | FADD Size Operand | FADDP | FIADD Size Addr | FCHS | FCOM Size Operand | FCOS | FDIV Size Operand | FDIVP | FIDIV Size Addr | FDIVR Size Operand | FDIVRP | FIDIVR Size Addr | FICOM Size Addr | FILD Size Addr Reg | FIST Size Addr | FLD Size Operand | FLD1 | FLDZ | FMUL Size Operand | FMULP | FIMUL Size Addr | FRNDINT | FSIN | FSQRT | FST Size Operand | FSTP Size Operand | FSUB Size Operand | FSUBP | FISUB Size Addr | FSUBR Size Operand | FSUBRP | FISUBR Size Addr | FTST | FCOMP Size Operand | FUCOMPP | FXCH | FNSTSW | FNOP | TEST Size Operand Operand | CMP Size Operand Operand | SETCC Cond Operand | PUSH Size Operand | POP Size Operand | JMP Operand | JXX Cond CLabel | CALL Imm | CLTD | LABEL CLabel | COMMENT _PackedString | SEGMENT CodeSegment | ASCII Bool [Char] | DATA Size [Imm] +data I386Regs {-# GHC_PRAGMA SRegs BitSet BitSet #-} +data Imm = ImmInt Int | ImmInteger Integer | ImmCLbl CLabel | ImmLab CSeq | ImmLit CSeq +type Index = Labda (Reg, Int) +data Operand = OpReg Reg | OpImm Imm | OpAddr Addr +data OrdList a {-# GHC_PRAGMA SeqList (OrdList a) (OrdList a) | ParList (OrdList a) (OrdList a) | OrdObj a | NoObj #-} +data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-} +data Size = B | HB | S | L | F | D +data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-} +type UniqSet a = UniqFM a +data Unique {-# GHC_PRAGMA MkUnique Int# #-} +baseRegOffset :: MagicId -> Int + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +callerSaves :: MagicId -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 21 \ (u0 :: MagicId) -> case u0 of { _ALG_ _ORIG_ AbsCSyn Hp -> _!_ True [] []; (u1 :: MagicId) -> _!_ False [] [] } _N_ #-} +eax :: Reg + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [0#] _N_ #-} +ebp :: Reg + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [6#] _N_ #-} +ebx :: Reg + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [1#] _N_ #-} +ecx :: Reg + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [2#] _N_ #-} +edi :: Reg + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [5#] _N_ #-} +edx :: Reg + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [3#] _N_ #-} +esi :: Reg + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [4#] _N_ #-} +esp :: Reg + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [7#] _N_ #-} +freeRegs :: [Reg] + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +is13Bits :: Integral a => a -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 12 _N_ _S_ "U(LU(U(ALASAAAA)AAA)AAAAAAAAAA)" {_A_ 3 _U_ 1112 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Int ] 1 { _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ }, [ Integer ] 1 { _A_ 1 _U_ 1 _N_ _S_ "U(PPP)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ } #-} +kindToSize :: PrimKind -> Size + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "E" _N_ _N_ #-} +offset :: Addr -> Int -> Labda Addr + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SL" _N_ _N_ #-} +printLabeledCodes :: PprStyle -> [I386Instr] -> CSeq + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +reservedRegs :: [Int] + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _NIL_ [Int] [] _N_ #-} +spRel :: Int -> Addr + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _N_ _N_ _N_ #-} +st0 :: Reg + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +st1 :: Reg + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stgRegMap :: MagicId -> Labda Reg + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +strImmLit :: [Char] -> Imm + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +instance MachineCode I386Instr + {-# GHC_PRAGMA _M_ I386Code {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 6 _!_ _TUP_5 [(I386Instr -> RegUsage), (I386Instr -> RegLiveness -> RegLiveness), (I386Instr -> (Reg -> Reg) -> I386Instr), (Reg -> Reg -> OrdList I386Instr), (Reg -> Reg -> OrdList I386Instr)] [_CONSTM_ MachineCode regUsage (I386Instr), _CONSTM_ MachineCode regLiveness (I386Instr), _CONSTM_ MachineCode patchRegs (I386Instr), _CONSTM_ MachineCode spillReg (I386Instr), _CONSTM_ MachineCode loadReg (I386Instr)] _N_ + regUsage = _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_, + regLiveness = _A_ 2 _U_ 11 _N_ _S_ "SU(LU(LL))" {_A_ 4 _U_ 1222 _N_ _N_ _N_ _N_} _N_ _N_, + patchRegs = _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_, + spillReg = _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_, + loadReg = _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-} +instance MachineRegisters I386Regs + {-# GHC_PRAGMA _M_ I386Code {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 7 _!_ _TUP_6 [([Int] -> I386Regs), (PrimKind -> I386Regs -> [Int]), (I386Regs -> Int# -> I386Regs), (I386Regs -> [Int] -> I386Regs), (I386Regs -> Int# -> I386Regs), (I386Regs -> [Int] -> I386Regs)] [_CONSTM_ MachineRegisters mkMRegs (I386Regs), _CONSTM_ MachineRegisters possibleMRegs (I386Regs), _CONSTM_ MachineRegisters useMReg (I386Regs), _CONSTM_ MachineRegisters useMRegs (I386Regs), _CONSTM_ MachineRegisters freeMReg (I386Regs), _CONSTM_ MachineRegisters freeMRegs (I386Regs)] _N_ + mkMRegs = _A_ 1 _U_ 1 _N_ _N_ _N_ _N_, + possibleMRegs = _A_ 2 _U_ 11 _N_ _S_ "EU(LL)" {_A_ 3 _U_ 111 _N_ _N_ _N_ _N_} _N_ _N_, + useMReg = _A_ 2 _U_ 12 _N_ _S_ "U(LL)P" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_, + useMRegs = _A_ 2 _U_ 11 _N_ _S_ "U(LL)L" {_A_ 3 _U_ 111 _N_ _N_ _N_ _N_} _N_ _N_, + freeMReg = _A_ 2 _U_ 12 _N_ _S_ "U(LL)P" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_, + freeMRegs = _A_ 2 _U_ 11 _N_ _S_ "U(LL)L" {_A_ 3 _U_ 111 _N_ _N_ _N_ _N_} _N_ _N_ #-} + diff --git a/ghc/compiler/nativeGen/I386Code.lhs b/ghc/compiler/nativeGen/I386Code.lhs new file mode 100644 index 0000000000..8730e86aa3 --- /dev/null +++ b/ghc/compiler/nativeGen/I386Code.lhs @@ -0,0 +1,1382 @@ +% +% (c) The AQUA Project, Glasgow University, 1993-1995 +% + +\section[I386Code]{The Native (I386) Machine Code} + +\begin{code} +#define ILIT2(x) ILIT(x) +#include "HsVersions.h" + +module I386Code ( + Addr(..), + Cond(..), Imm(..), Operand(..), Size(..), + Base(..), Index(..), Displacement(..), + I386Code(..),I386Instr(..),I386Regs, + strImmLit, --UNUSED: strImmLab, + spRel, + + printLabeledCodes, + + baseRegOffset, stgRegMap, callerSaves, + + is13Bits, offset, + + kindToSize, + + st0, st1, eax, ebx, ecx, edx, esi, edi, ebp, esp, + + freeRegs, reservedRegs, + + -- and, for self-sufficiency ... + CLabel, CodeSegment, OrdList, PrimKind, Reg, UniqSet(..), + UniqFM, FiniteMap, Unique, MagicId, CSeq, BitSet + ) where + +IMPORT_Trace + +import AbsCSyn ( MagicId(..) ) +import AsmRegAlloc ( MachineCode(..), MachineRegisters(..), FutureLive(..), + Reg(..), RegUsage(..), RegLiveness(..) + ) +import BitSet +import CgCompInfo ( mAX_Double_REG, mAX_Float_REG, mAX_Vanilla_REG ) +import CLabelInfo ( CLabel, pprCLabel, externallyVisibleCLabel, charToC ) +import FiniteMap +import Maybes ( Maybe(..), maybeToBool ) +import OrdList ( OrdList, mkUnitList, flattenOrdList ) +import Outputable +import PrimKind ( PrimKind(..) ) +import UniqSet +import Stix +import Unpretty +import Util +\end{code} + +%************************************************************************ +%* * +\subsection[I386Reg]{The Native (I386) Machine Register Table} +%* * +%************************************************************************ + +- All registers except 7 (esp) are available for use. +- Only ebx, esi, edi and esp are available across a C call (they are callee-saves). +- Registers 0-7 have 16-bit counterparts (ax, bx etc.) +- Registers 0-3 have 8 bit counterparts (ah, bh etc.) +- Registers 8-15 hold extended floating point values. + +ToDo: Deal with stg registers that live as offsets from BaseReg!(JSM) + +\begin{code} + +gReg,fReg :: Int -> Int +gReg x = x +fReg x = (8 + x) + +st0, st1, st2, st3, st4, st5, st6, st7, eax, ebx, ecx, edx, esp :: Reg +eax = case (gReg 0) of { IBOX(g0) -> FixedReg g0 } +ebx = case (gReg 1) of { IBOX(g1) -> FixedReg g1 } +ecx = case (gReg 2) of { IBOX(g2) -> FixedReg g2 } +edx = case (gReg 3) of { IBOX(g3) -> FixedReg g3 } +esi = case (gReg 4) of { IBOX(g4) -> FixedReg g4 } +edi = case (gReg 5) of { IBOX(g5) -> FixedReg g5 } +ebp = case (gReg 6) of { IBOX(g6) -> FixedReg g6 } +esp = case (gReg 7) of { IBOX(g7) -> FixedReg g7 } +st0 = realReg (fReg 0) +st1 = realReg (fReg 1) +st2 = realReg (fReg 2) +st3 = realReg (fReg 3) +st4 = realReg (fReg 4) +st5 = realReg (fReg 5) +st6 = realReg (fReg 6) +st7 = realReg (fReg 7) + +realReg n@IBOX(i) = if _IS_TRUE_(freeReg i) then MappedReg i else FixedReg i + +\end{code} + +%************************************************************************ +%* * +\subsection[TheI386Code]{The datatype for i386 assembly language} +%* * +%************************************************************************ + +Here is a definition of the I386 assembly language. + +\begin{code} + +data Imm = ImmInt Int + | ImmInteger Integer -- Sigh. + | ImmCLbl CLabel -- AbstractC Label (with baggage) + | ImmLab Unpretty -- Simple string label (underscored) + | ImmLit Unpretty -- Simple string + deriving () + +--UNUSED:strImmLab s = ImmLab (uppStr s) +strImmLit s = ImmLit (uppStr s) + +data Cond = ALWAYS + | GEU + | LU + | EQ + | GT + | GE + | GU + | LT + | LE + | LEU + | NE + | NEG + | POS + deriving () + + +data Size = B + | HB + | S -- unused ? + | L + | F + | D + deriving () + +data Operand = OpReg Reg -- register + | OpImm Imm -- immediate value + | OpAddr Addr -- memory reference + deriving () + +data Addr = Addr Base Index Displacement + | ImmAddr Imm Int + -- deriving Eq + +type Base = Maybe Reg +type Index = Maybe (Reg, Int) -- Int is 2, 4 or 8 +type Displacement = Imm + +data I386Instr = + +-- Moves. + + MOV Size Operand Operand + | MOVZX Size Operand Operand -- size is the size of operand 2 + | MOVSX Size Operand Operand -- size is the size of operand 2 + +-- Load effective address (also a very useful three-operand add instruction :-) + + | LEA Size Operand Operand + +-- Int Arithmetic. + + | ADD Size Operand Operand + | SUB Size Operand Operand + +-- Multiplication (signed and unsigned), Division (signed and unsigned), +-- result in %eax, %edx. + + | IMUL Size Operand Operand + | IDIV Size Operand + +-- Simple bit-twiddling. + + | AND Size Operand Operand + | OR Size Operand Operand + | XOR Size Operand Operand + | NOT Size Operand + | NEGI Size Operand -- NEG instruction (name clash with Cond) + | SHL Size Operand Operand -- 1st operand must be an Imm + | SAR Size Operand Operand -- 1st operand must be an Imm + | SHR Size Operand Operand -- 1st operand must be an Imm + | NOP + +-- Float Arithmetic. -- ToDo for 386 + +-- Note that we cheat by treating F{ABS,MOV,NEG} of doubles as single instructions +-- right up until we spit them out. + + | SAHF -- stores ah into flags + | FABS + | FADD Size Operand -- src + | FADDP + | FIADD Size Addr -- src + | FCHS + | FCOM Size Operand -- src + | FCOS + | FDIV Size Operand -- src + | FDIVP + | FIDIV Size Addr -- src + | FDIVR Size Operand -- src + | FDIVRP + | FIDIVR Size Addr -- src + | FICOM Size Addr -- src + | FILD Size Addr Reg -- src, dst + | FIST Size Addr -- dst + | FLD Size Operand -- src + | FLD1 + | FLDZ + | FMUL Size Operand -- src + | FMULP + | FIMUL Size Addr -- src + | FRNDINT + | FSIN + | FSQRT + | FST Size Operand -- dst + | FSTP Size Operand -- dst + | FSUB Size Operand -- src + | FSUBP + | FISUB Size Addr -- src + | FSUBR Size Operand -- src + | FSUBRP + | FISUBR Size Addr -- src + | FTST + | FCOMP Size Operand -- src + | FUCOMPP + | FXCH + | FNSTSW + | FNOP + +-- Comparison + + | TEST Size Operand Operand + | CMP Size Operand Operand + | SETCC Cond Operand + +-- Stack Operations. + + | PUSH Size Operand + | POP Size Operand + +-- Jumping around. + + | JMP Operand -- target + | JXX Cond CLabel -- target + | CALL Imm + +-- Other things. + + | CLTD -- sign extend %eax into %edx:%eax + +-- Pseudo-ops. + + | LABEL CLabel + | COMMENT FAST_STRING + | SEGMENT CodeSegment + | ASCII Bool String -- needs backslash conversion? + | DATA Size [Imm] + +type I386Code = OrdList I386Instr + +\end{code} + +%************************************************************************ +%* * +\subsection[TheI386Pretty]{Pretty-printing the I386 Assembly Language} +%* * +%************************************************************************ + +\begin{code} + +printLabeledCodes :: PprStyle -> [I386Instr] -> Unpretty +printLabeledCodes sty codes = uppAboves (map (pprI386Instr sty) codes) + +\end{code} + +Printing the pieces... + +\begin{code} + +pprReg :: Size -> Reg -> Unpretty + +pprReg s (FixedReg i) = pprI386Reg s i +pprReg s (MappedReg i) = pprI386Reg s i +pprReg s other = uppStr (show other) -- should only happen when debugging + +pprI386Reg :: Size -> FAST_INT -> Unpretty +pprI386Reg B i = uppPStr + (case i of { + ILIT( 0) -> SLIT("%al"); ILIT( 1) -> SLIT("%bl"); + ILIT( 2) -> SLIT("%cl"); ILIT( 3) -> SLIT("%dl"); + _ -> SLIT("very naughty I386 byte register") + }) + +pprI386Reg HB i = uppPStr + (case i of { + ILIT( 0) -> SLIT("%ah"); ILIT( 1) -> SLIT("%bh"); + ILIT( 2) -> SLIT("%ch"); ILIT( 3) -> SLIT("%dh"); + _ -> SLIT("very naughty I386 high byte register") + }) + +pprI386Reg S i = uppPStr + (case i of { + ILIT( 0) -> SLIT("%ax"); ILIT( 1) -> SLIT("%bx"); + ILIT( 2) -> SLIT("%cx"); ILIT( 3) -> SLIT("%dx"); + ILIT( 4) -> SLIT("%si"); ILIT( 5) -> SLIT("%di"); + ILIT( 6) -> SLIT("%bp"); ILIT( 7) -> SLIT("%sp"); + _ -> SLIT("very naughty I386 word register") + }) + +pprI386Reg L i = uppPStr + (case i of { + ILIT( 0) -> SLIT("%eax"); ILIT( 1) -> SLIT("%ebx"); + ILIT( 2) -> SLIT("%ecx"); ILIT( 3) -> SLIT("%edx"); + ILIT( 4) -> SLIT("%esi"); ILIT( 5) -> SLIT("%edi"); + ILIT( 6) -> SLIT("%ebp"); ILIT( 7) -> SLIT("%esp"); + _ -> SLIT("very naughty I386 double word register") + }) + +pprI386Reg F i = uppPStr + (case i of { +--ToDo: rm these + ILIT( 8) -> SLIT("%st(0)"); ILIT( 9) -> SLIT("%st(1)"); + ILIT(10) -> SLIT("%st(2)"); ILIT(11) -> SLIT("%st(3)"); + ILIT(12) -> SLIT("%st(4)"); ILIT(13) -> SLIT("%st(5)"); + ILIT(14) -> SLIT("%st(6)"); ILIT(15) -> SLIT("%st(7)"); + _ -> SLIT("very naughty I386 float register") + }) + +pprI386Reg D i = uppPStr + (case i of { +--ToDo: rm these + ILIT( 8) -> SLIT("%st(0)"); ILIT( 9) -> SLIT("%st(1)"); + ILIT(10) -> SLIT("%st(2)"); ILIT(11) -> SLIT("%st(3)"); + ILIT(12) -> SLIT("%st(4)"); ILIT(13) -> SLIT("%st(5)"); + ILIT(14) -> SLIT("%st(6)"); ILIT(15) -> SLIT("%st(7)"); + _ -> SLIT("very naughty I386 float register") + }) + +pprCond :: Cond -> Unpretty -- ToDo +pprCond x = uppPStr + (case x of { + GEU -> SLIT("ae"); LU -> SLIT("b"); + EQ -> SLIT("e"); GT -> SLIT("g"); + GE -> SLIT("ge"); GU -> SLIT("a"); + LT -> SLIT("l"); LE -> SLIT("le"); + LEU -> SLIT("be"); NE -> SLIT("ne"); + NEG -> SLIT("s"); POS -> SLIT("ns"); + ALWAYS -> SLIT("mp"); -- hack + _ -> error "Spix: iI386Code: unknown conditional!" + }) + +pprDollImm :: PprStyle -> Imm -> Unpretty + +pprDollImm sty i = uppBesides [ uppPStr SLIT("$"), pprImm sty i] + +pprImm :: PprStyle -> Imm -> Unpretty + +pprImm sty (ImmInt i) = uppInt i +pprImm sty (ImmInteger i) = uppInteger i +pprImm sty (ImmCLbl l) = pprCLabel sty l +pprImm sty (ImmLab l) = l + +--pprImm (PprForAsm _ False _) (ImmLab s) = s +--pprImm _ (ImmLab s) = uppBeside (uppChar '_') s + +pprImm sty (ImmLit s) = s + +pprAddr :: PprStyle -> Addr -> Unpretty +pprAddr sty (ImmAddr imm off) + = uppBesides [pprImm sty imm, + if off > 0 then uppChar '+' else uppPStr SLIT(""), + if off == 0 then uppPStr SLIT("") else uppInt off + ] +pprAddr sty (Addr Nothing Nothing displacement) + = uppBesides [pprDisp sty displacement] +pprAddr sty (Addr base index displacement) + = uppBesides [pprDisp sty displacement, + uppChar '(', + pprBase base, + pprIndex index, + uppChar ')' + ] + where + pprBase (Just r) = uppBesides [pprReg L r, + case index of + Nothing -> uppPStr SLIT("") + _ -> uppChar ',' + ] + pprBase _ = uppPStr SLIT("") + pprIndex (Just (r,i)) = uppBesides [pprReg L r, uppChar ',', uppInt i] + pprIndex _ = uppPStr SLIT("") + +pprDisp sty (ImmInt 0) = uppPStr SLIT("") +--pprDisp sty (ImmInteger 0) = uppPStr SLIT("") +pprDisp sty d = pprImm sty d + +pprOperand :: PprStyle -> Size -> Operand -> Unpretty +pprOperand sty s (OpReg r) = pprReg s r +pprOperand sty s (OpImm i) = pprDollImm sty i +pprOperand sty s (OpAddr ea) = pprAddr sty ea + +pprSize :: Size -> Unpretty +pprSize x = uppPStr + (case x of + B -> SLIT("b") + HB -> SLIT("b") + S -> SLIT("w") + L -> SLIT("l") + F -> SLIT("s") + D -> SLIT("l") + ) + +pprSizeOp :: PprStyle -> FAST_STRING -> Size -> Operand -> Unpretty +pprSizeOp sty name size op1 = + uppBesides [ + uppChar '\t', + uppPStr name, + pprSize size, + uppChar ' ', + pprOperand sty size op1 + ] + +pprSizeOpOp :: PprStyle -> FAST_STRING -> Size -> Operand -> Operand -> Unpretty +pprSizeOpOp sty name size op1 op2 = + uppBesides [ + uppChar '\t', + uppPStr name, + pprSize size, + uppChar ' ', + pprOperand sty size op1, + uppComma, + pprOperand sty size op2 + ] + +pprSizeOpReg :: PprStyle -> FAST_STRING -> Size -> Operand -> Reg -> Unpretty +pprSizeOpReg sty name size op1 reg = + uppBesides [ + uppChar '\t', + uppPStr name, + pprSize size, + uppChar ' ', + pprOperand sty size op1, + uppComma, + pprReg size reg + ] + +pprSizeAddr :: PprStyle -> FAST_STRING -> Size -> Addr -> Unpretty +pprSizeAddr sty name size op = + uppBesides [ + uppChar '\t', + uppPStr name, + pprSize size, + uppChar ' ', + pprAddr sty op + ] + +pprSizeAddrReg :: PprStyle -> FAST_STRING -> Size -> Addr -> Reg -> Unpretty +pprSizeAddrReg sty name size op dst = + uppBesides [ + uppChar '\t', + uppPStr name, + pprSize size, + uppChar ' ', + pprAddr sty op, + uppComma, + pprReg size dst + ] + +pprOpOp :: PprStyle -> FAST_STRING -> Size -> Operand -> Operand -> Unpretty +pprOpOp sty name size op1 op2 = + uppBesides [ + uppChar '\t', + uppPStr name, + uppChar ' ', + pprOperand sty size op1, + uppComma, + pprOperand sty size op2 + ] + +pprSizeOpOpCoerce :: PprStyle -> FAST_STRING -> Size -> Size -> Operand -> Operand -> Unpretty +pprSizeOpOpCoerce sty name size1 size2 op1 op2 = + uppBesides [ uppChar '\t', uppPStr name, uppChar ' ', + pprOperand sty size1 op1, + uppComma, + pprOperand sty size2 op2 + ] + +pprCondInstr :: PprStyle -> FAST_STRING -> Cond -> Unpretty -> Unpretty +pprCondInstr sty name cond arg = + uppBesides [ uppChar '\t', uppPStr name, pprCond cond, uppChar ' ', arg] + +pprI386Instr :: PprStyle -> I386Instr -> Unpretty +pprI386Instr sty (MOV size (OpReg src) (OpReg dst)) -- hack + | src == dst + = uppPStr SLIT("") +pprI386Instr sty (MOV size src dst) + = pprSizeOpOp sty SLIT("mov") size src dst +pprI386Instr sty (MOVZX size src dst) = pprSizeOpOpCoerce sty SLIT("movzx") L size src dst +pprI386Instr sty (MOVSX size src dst) = pprSizeOpOpCoerce sty SLIT("movxs") L size src dst + +-- here we do some patching, since the physical registers are only set late +-- in the code generation. +pprI386Instr sty (LEA size (OpAddr (Addr src1@(Just reg1) (Just (reg2,1)) (ImmInt 0))) dst@(OpReg reg3)) + | reg1 == reg3 + = pprSizeOpOp sty SLIT("add") size (OpReg reg2) dst +pprI386Instr sty (LEA size (OpAddr (Addr src1@(Just reg1) (Just (reg2,1)) (ImmInt 0))) dst@(OpReg reg3)) + | reg2 == reg3 + = pprSizeOpOp sty SLIT("add") size (OpReg reg1) dst +pprI386Instr sty (LEA size (OpAddr (Addr src1@(Just reg1) Nothing displ)) dst@(OpReg reg3)) + | reg1 == reg3 + = pprI386Instr sty (ADD size (OpImm displ) dst) +pprI386Instr sty (LEA size src dst) = pprSizeOpOp sty SLIT("lea") size src dst + +pprI386Instr sty (ADD size (OpImm (ImmInt (-1))) dst) + = pprSizeOp sty SLIT("dec") size dst +pprI386Instr sty (ADD size (OpImm (ImmInt 1)) dst) + = pprSizeOp sty SLIT("inc") size dst +pprI386Instr sty (ADD size src dst) + = pprSizeOpOp sty SLIT("add") size src dst +pprI386Instr sty (SUB size src dst) = pprSizeOpOp sty SLIT("sub") size src dst +pprI386Instr sty (IMUL size op1 op2) = pprSizeOpOp sty SLIT("imul") size op1 op2 +pprI386Instr sty (IDIV size op) = pprSizeOp sty SLIT("idiv") size op + +pprI386Instr sty (AND size src dst) = pprSizeOpOp sty SLIT("and") size src dst +pprI386Instr sty (OR size src dst) = pprSizeOpOp sty SLIT("or") size src dst +pprI386Instr sty (XOR size src dst) = pprSizeOpOp sty SLIT("xor") size src dst +pprI386Instr sty (NOT size op) = pprSizeOp sty SLIT("not") size op +pprI386Instr sty (NEGI size op) = pprSizeOp sty SLIT("neg") size op +pprI386Instr sty (SHL size imm dst) = pprSizeOpOp sty SLIT("shl") size imm dst +pprI386Instr sty (SAR size imm dst) = pprSizeOpOp sty SLIT("sar") size imm dst +pprI386Instr sty (SHR size imm dst) = pprSizeOpOp sty SLIT("shr") size imm dst + +pprI386Instr sty (CMP size src dst) = pprSizeOpOp sty SLIT("cmp") size src dst +pprI386Instr sty (TEST size src dst) = pprSizeOpOp sty SLIT("test") size src dst +pprI386Instr sty (PUSH size op) = pprSizeOp sty SLIT("push") size op +pprI386Instr sty (POP size op) = pprSizeOp sty SLIT("pop") size op + +pprI386Instr sty (NOP) = uppPStr SLIT("\tnop") +pprI386Instr sty (CLTD) = uppPStr SLIT("\tcltd") + +pprI386Instr sty (SETCC cond op) = pprCondInstr sty SLIT("set") cond (pprOperand sty B op) + +pprI386Instr sty (JXX cond lab) = pprCondInstr sty SLIT("j") cond (pprCLabel sty lab) + +pprI386Instr sty (JMP (OpImm imm)) = uppBeside (uppPStr SLIT("\tjmp ")) (pprImm sty imm) +pprI386Instr sty (JMP op) = uppBeside (uppPStr SLIT("\tjmp *")) (pprOperand sty L op) + +pprI386Instr sty (CALL imm) = + uppBesides [ uppPStr SLIT("\tcall "), pprImm sty imm ] + +pprI386Instr sty SAHF = uppPStr SLIT("\tsahf") +pprI386Instr sty FABS = uppPStr SLIT("\tfabs") + +pprI386Instr sty (FADD sz src@(OpAddr _)) + = uppBesides [uppPStr SLIT("\tfadd"), pprSize sz, uppChar ' ', pprOperand sty sz src] +pprI386Instr sty (FADD sz src) + = uppPStr SLIT("\tfadd") +pprI386Instr sty FADDP + = uppPStr SLIT("\tfaddp") +pprI386Instr sty (FMUL sz src) + = uppBesides [uppPStr SLIT("\tfmul"), pprSize sz, uppChar ' ', pprOperand sty sz src] +pprI386Instr sty FMULP + = uppPStr SLIT("\tfmulp") +pprI386Instr sty (FIADD size op) = pprSizeAddr sty SLIT("fiadd") size op +pprI386Instr sty FCHS = uppPStr SLIT("\tfchs") +pprI386Instr sty (FCOM size op) = pprSizeOp sty SLIT("fcom") size op +pprI386Instr sty FCOS = uppPStr SLIT("\tfcos") +pprI386Instr sty (FIDIV size op) = pprSizeAddr sty SLIT("fidiv") size op +pprI386Instr sty (FDIV sz src) + = uppBesides [uppPStr SLIT("\tfdiv"), pprSize sz, uppChar ' ', pprOperand sty sz src] +pprI386Instr sty FDIVP + = uppPStr SLIT("\tfdivp") +pprI386Instr sty (FDIVR sz src) + = uppBesides [uppPStr SLIT("\tfdivr"), pprSize sz, uppChar ' ', pprOperand sty sz src] +pprI386Instr sty FDIVRP + = uppPStr SLIT("\tfdivpr") +pprI386Instr sty (FIDIVR size op) = pprSizeAddr sty SLIT("fidivr") size op +pprI386Instr sty (FICOM size op) = pprSizeAddr sty SLIT("ficom") size op +pprI386Instr sty (FILD sz op reg) = pprSizeAddrReg sty SLIT("fild") sz op reg +pprI386Instr sty (FIST size op) = pprSizeAddr sty SLIT("fist") size op +pprI386Instr sty (FLD sz (OpImm (ImmCLbl src))) + = uppBesides [uppPStr SLIT("\tfld"),pprSize sz,uppChar ' ',pprCLabel sty src] +pprI386Instr sty (FLD sz src) + = uppBesides [uppPStr SLIT("\tfld"),pprSize sz,uppChar ' ',pprOperand sty sz src] +pprI386Instr sty FLD1 = uppPStr SLIT("\tfld1") +pprI386Instr sty FLDZ = uppPStr SLIT("\tfldz") +pprI386Instr sty (FIMUL size op) = pprSizeAddr sty SLIT("fimul") size op +pprI386Instr sty FRNDINT = uppPStr SLIT("\tfrndint") +pprI386Instr sty FSIN = uppPStr SLIT("\tfsin") +pprI386Instr sty FSQRT = uppPStr SLIT("\tfsqrt") +pprI386Instr sty (FST sz dst) + = uppBesides [uppPStr SLIT("\tfst"), pprSize sz, uppChar ' ', pprOperand sty sz dst] +pprI386Instr sty (FSTP sz dst) + = uppBesides [uppPStr SLIT("\tfstp"), pprSize sz, uppChar ' ', pprOperand sty sz dst] +pprI386Instr sty (FISUB size op) = pprSizeAddr sty SLIT("fisub") size op +pprI386Instr sty (FSUB sz src) + = uppBesides [uppPStr SLIT("\tfsub"), pprSize sz, uppChar ' ', pprOperand sty sz src] +pprI386Instr sty FSUBP + = uppPStr SLIT("\tfsubp") +pprI386Instr sty (FSUBR size src) + = pprSizeOp sty SLIT("fsubr") size src +pprI386Instr sty FSUBRP + = uppPStr SLIT("\tfsubpr") +pprI386Instr sty (FISUBR size op) + = pprSizeAddr sty SLIT("fisubr") size op +pprI386Instr sty FTST = uppPStr SLIT("\tftst") +pprI386Instr sty (FCOMP sz op) + = uppBesides [uppPStr SLIT("\tfcomp"), pprSize sz, uppChar ' ', pprOperand sty sz op] +pprI386Instr sty FUCOMPP = uppPStr SLIT("\tfucompp") +pprI386Instr sty FXCH = uppPStr SLIT("\tfxch") +pprI386Instr sty FNSTSW = uppPStr SLIT("\tfnstsw %ax") +pprI386Instr sty FNOP = uppPStr SLIT("") + +pprI386Instr sty (LABEL clab) = + uppBesides [ + if (externallyVisibleCLabel clab) then + uppBesides [uppPStr SLIT(".globl "), pprLab, uppChar '\n'] + else + uppNil, + pprLab, + uppChar ':' + ] + where pprLab = pprCLabel sty clab + +pprI386Instr sty (COMMENT s) = uppBeside (uppPStr SLIT("# ")) (uppPStr s) + +pprI386Instr sty (SEGMENT TextSegment) + = uppPStr SLIT(".text\n\t.align 4") + +pprI386Instr sty (SEGMENT DataSegment) + = uppPStr SLIT(".data\n\t.align 2") + +pprI386Instr sty (ASCII False str) = + uppBesides [ + uppStr "\t.asciz \"", + uppStr str, + uppChar '"' + ] + +pprI386Instr sty (ASCII True str) = uppBeside (uppStr "\t.ascii \"") (asciify str 60) + where + asciify :: String -> Int -> Unpretty + asciify [] _ = uppStr ("\\0\"") + asciify s n | n <= 0 = uppBeside (uppStr "\"\n\t.ascii \"") (asciify s 60) + asciify ('\\':cs) n = uppBeside (uppStr "\\\\") (asciify cs (n-1)) + asciify ('\"':cs) n = uppBeside (uppStr "\\\"") (asciify cs (n-1)) + asciify (c:cs) n | isPrint c = uppBeside (uppChar c) (asciify cs (n-1)) + asciify [c] _ = uppBeside (uppStr (charToC c)) (uppStr ("\\0\"")) + asciify (c:(cs@(d:_))) n | isDigit d = + uppBeside (uppStr (charToC c)) (asciify cs 0) + | otherwise = + uppBeside (uppStr (charToC c)) (asciify cs (n-1)) + +pprI386Instr sty (DATA s xs) = uppInterleave (uppChar '\n') (map pp_item xs) + where pp_item x = case s of + B -> uppBeside (uppPStr SLIT("\t.byte\t")) (pprImm sty x) + HB-> uppBeside (uppPStr SLIT("\t.byte\t")) (pprImm sty x) + S -> uppBeside (uppPStr SLIT("\t.word\t")) (pprImm sty x) + L -> uppBeside (uppPStr SLIT("\t.long\t")) (pprImm sty x) + F -> uppBeside (uppPStr SLIT("\t.long\t")) (pprImm sty x) + D -> uppBeside (uppPStr SLIT("\t.double\t")) (pprImm sty x) + +\end{code} + +%************************************************************************ +%* * +\subsection[Schedule]{Register allocation information} +%* * +%************************************************************************ + +\begin{code} + +data I386Regs = SRegs BitSet BitSet + +instance MachineRegisters I386Regs where + mkMRegs xs = SRegs (mkBS ints) (mkBS floats') + where + (ints, floats) = partition (< 8) xs + floats' = map (subtract 8) floats + + possibleMRegs FloatKind (SRegs _ floats) = [ x + 8 | x <- listBS floats] + possibleMRegs DoubleKind (SRegs _ floats) = [ x + 8 | x <- listBS floats] + possibleMRegs _ (SRegs ints _) = listBS ints + + useMReg (SRegs ints floats) n = + if n _LT_ ILIT(8) then SRegs (ints `minusBS` singletonBS IBOX(n)) floats + else SRegs ints (floats `minusBS` singletonBS (IBOX(n _SUB_ ILIT(8)))) + + useMRegs (SRegs ints floats) xs = + SRegs (ints `minusBS` ints') + (floats `minusBS` floats') + where + SRegs ints' floats' = mkMRegs xs + + freeMReg (SRegs ints floats) n = + if n _LT_ ILIT(8) then SRegs (ints `unionBS` singletonBS IBOX(n)) floats + else SRegs ints (floats `unionBS` singletonBS (IBOX(n _SUB_ ILIT(8)))) + + freeMRegs (SRegs ints floats) xs = + SRegs (ints `unionBS` ints') + (floats `unionBS` floats') + where + SRegs ints' floats' = mkMRegs xs + +instance MachineCode I386Instr where + -- Alas, we don't do anything clever with our OrdLists +--OLD: +-- flatten = flattenOrdList + + regUsage = i386RegUsage + regLiveness = i386RegLiveness + patchRegs = i386PatchRegs + + -- We spill just below the stack pointer, leaving two words per spill location. + spillReg dyn (MemoryReg i pk) + = trace "spillsave" + (mkUnitList (MOV (kindToSize pk) (OpReg dyn) (OpAddr (spRel (-2 * i))))) + loadReg (MemoryReg i pk) dyn + = trace "spillload" + (mkUnitList (MOV (kindToSize pk) (OpAddr (spRel (-2 * i))) (OpReg dyn))) + +--spRel gives us a stack relative addressing mode for volatile temporaries +--and for excess call arguments. + +spRel + :: Int -- desired stack offset in words, positive or negative + -> Addr +spRel n = Addr (Just esp) Nothing (ImmInt (n * 4)) + +kindToSize :: PrimKind -> Size +kindToSize PtrKind = L +kindToSize CodePtrKind = L +kindToSize DataPtrKind = L +kindToSize RetKind = L +kindToSize InfoPtrKind = L +kindToSize CostCentreKind = L +kindToSize CharKind = L +kindToSize IntKind = L +kindToSize WordKind = L +kindToSize AddrKind = L +kindToSize FloatKind = F +kindToSize DoubleKind = D +kindToSize ArrayKind = L +kindToSize ByteArrayKind = L +kindToSize StablePtrKind = L +kindToSize MallocPtrKind = L + +\end{code} + +@i386RegUsage@ returns the sets of src and destination registers used by +a particular instruction. Machine registers that are pre-allocated +to stgRegs are filtered out, because they are uninteresting from a +register allocation standpoint. (We wouldn't want them to end up on +the free list!) + +\begin{code} + +i386RegUsage :: I386Instr -> RegUsage +i386RegUsage instr = case instr of + MOV sz src dst -> usage2 src dst + MOVZX sz src dst -> usage2 src dst + MOVSX sz src dst -> usage2 src dst + LEA sz src dst -> usage2 src dst + ADD sz src dst -> usage2 src dst + SUB sz src dst -> usage2 src dst + IMUL sz src dst -> usage2 src dst + IDIV sz src -> usage (eax:edx:opToReg src) [eax,edx] + AND sz src dst -> usage2 src dst + OR sz src dst -> usage2 src dst + XOR sz src dst -> usage2 src dst + NOT sz op -> usage1 op + NEGI sz op -> usage1 op + SHL sz imm dst -> usage1 dst -- imm has to be an Imm + SAR sz imm dst -> usage1 dst -- imm has to be an Imm + SHR sz imm dst -> usage1 dst -- imm has to be an Imm + PUSH sz op -> usage (opToReg op) [] + POP sz op -> usage [] (opToReg op) + TEST sz src dst -> usage (opToReg src ++ opToReg dst) [] + CMP sz src dst -> usage (opToReg src ++ opToReg dst) [] + SETCC cond op -> usage [] (opToReg op) + JXX cond label -> usage [] [] + JMP op -> usage (opToReg op) freeRegs + CALL imm -> usage [] callClobberedRegs + CLTD -> usage [eax] [edx] + NOP -> usage [] [] + SAHF -> usage [eax] [] + FABS -> usage [st0] [st0] + FADD sz src -> usage (st0:opToReg src) [st0] -- allFPRegs + FADDP -> usage [st0,st1] [st0] -- allFPRegs + FIADD sz asrc -> usage (addrToRegs asrc) [st0] + FCHS -> usage [st0] [st0] + FCOM sz src -> usage (st0:opToReg src) [] + FCOS -> usage [st0] [st0] + FDIV sz src -> usage (st0:opToReg src) [st0] + FDIVP -> usage [st0,st1] [st0] + FDIVRP -> usage [st0,st1] [st0] + FIDIV sz asrc -> usage (addrToRegs asrc) [st0] + FDIVR sz src -> usage (st0:opToReg src) [st0] + FIDIVR sz asrc -> usage (addrToRegs asrc) [st0] + FICOM sz asrc -> usage (addrToRegs asrc) [] + FILD sz asrc dst -> usage (addrToRegs asrc) [dst] -- allFPRegs + FIST sz adst -> usage (st0:addrToRegs adst) [] + FLD sz src -> usage (opToReg src) [st0] -- allFPRegs + FLD1 -> usage [] [st0] -- allFPRegs + FLDZ -> usage [] [st0] -- allFPRegs + FMUL sz src -> usage (st0:opToReg src) [st0] + FMULP -> usage [st0,st1] [st0] + FIMUL sz asrc -> usage (addrToRegs asrc) [st0] + FRNDINT -> usage [st0] [st0] + FSIN -> usage [st0] [st0] + FSQRT -> usage [st0] [st0] + FST sz (OpReg r) -> usage [st0] [r] + FST sz dst -> usage (st0:opToReg dst) [] + FSTP sz (OpReg r) -> usage [st0] [r] -- allFPRegs + FSTP sz dst -> usage (st0:opToReg dst) [] -- allFPRegs + FSUB sz src -> usage (st0:opToReg src) [st0] -- allFPRegs + FSUBR sz src -> usage (st0:opToReg src) [st0] -- allFPRegs + FISUB sz asrc -> usage (addrToRegs asrc) [st0] + FSUBP -> usage [st0,st1] [st0] -- allFPRegs + FSUBRP -> usage [st0,st1] [st0] -- allFPRegs + FISUBR sz asrc -> usage (addrToRegs asrc) [st0] + FTST -> usage [st0] [] + FCOMP sz op -> usage (st0:opToReg op) [st0] -- allFPRegs + FUCOMPP -> usage [st0, st1] [] -- allFPRegs + FXCH -> usage [st0, st1] [st0, st1] + FNSTSW -> usage [] [eax] + _ -> noUsage + + where + + usage2 :: Operand -> Operand -> RegUsage + usage2 op (OpReg reg) = usage (opToReg op) [reg] + usage2 op (OpAddr ea) = usage (opToReg op ++ addrToRegs ea) [] + usage2 op (OpImm imm) = usage (opToReg op) [] + usage1 :: Operand -> RegUsage + usage1 (OpReg reg) = usage [reg] [reg] + usage1 (OpAddr ea) = usage (addrToRegs ea) [] + allFPRegs = [st0,st1,st2,st3,st4,st5,st6,st7] + --callClobberedRegs = [ eax, ecx, edx ] -- according to gcc, anyway. + callClobberedRegs = [eax] + +-- General purpose register collecting functions. + + opToReg (OpReg reg) = [reg] + opToReg (OpImm imm) = [] + opToReg (OpAddr ea) = addrToRegs ea + + addrToRegs (Addr base index _) = baseToReg base ++ indexToReg index + where baseToReg Nothing = [] + baseToReg (Just r) = [r] + indexToReg Nothing = [] + indexToReg (Just (r,_)) = [r] + addrToRegs (ImmAddr _ _) = [] + + usage src dst = RU (mkUniqSet (filter interesting src)) + (mkUniqSet (filter interesting dst)) + + interesting (FixedReg _) = False + interesting _ = True + +freeRegs :: [Reg] +freeRegs = freeMappedRegs (\ x -> x) [0..15] + +freeMappedRegs :: (Int -> Int) -> [Int] -> [Reg] + +freeMappedRegs modify nums + = foldr free [] nums + where + free n acc + = let + modified_i = case (modify n) of { IBOX(x) -> x } + in + if _IS_TRUE_(freeReg modified_i) then (MappedReg modified_i) : acc else acc + +freeSet :: UniqSet Reg +freeSet = mkUniqSet freeRegs + +noUsage :: RegUsage +noUsage = RU emptyUniqSet emptyUniqSet + +endUsage :: RegUsage +endUsage = RU emptyUniqSet freeSet + +\end{code} + +@i386RegLiveness@ takes future liveness information and modifies it according to +the semantics of branches and labels. (An out-of-line branch clobbers the liveness +passed back by the following instruction; a forward local branch passes back the +liveness from the target label; a conditional branch merges the liveness from the +target and the liveness from its successor; a label stashes away the current liveness +in the future liveness environment). + +\begin{code} +i386RegLiveness :: I386Instr -> RegLiveness -> RegLiveness +i386RegLiveness instr info@(RL live future@(FL all env)) = case instr of + + JXX _ lbl -> RL (lookup lbl `unionUniqSets` live) future + JMP _ -> RL emptyUniqSet future + CALL _ -> RL live future + LABEL lbl -> RL live (FL (all `unionUniqSets` live) (addToFM env lbl live)) + _ -> info + + where + lookup lbl = case lookupFM env lbl of + Just regs -> regs + Nothing -> trace ("Missing " ++ (uppShow 80 (pprCLabel (PprForAsm (\_->False) False id) lbl)) ++ + " in future?") emptyUniqSet + +\end{code} + +@i386PatchRegs@ takes an instruction (possibly with MemoryReg/UnmappedReg registers) and +changes all register references according to the supplied environment. + +\begin{code} + +i386PatchRegs :: I386Instr -> (Reg -> Reg) -> I386Instr +i386PatchRegs instr env = case instr of + MOV sz src dst -> patch2 (MOV sz) src dst + MOVZX sz src dst -> patch2 (MOVZX sz) src dst + MOVSX sz src dst -> patch2 (MOVSX sz) src dst + LEA sz src dst -> patch2 (LEA sz) src dst + ADD sz src dst -> patch2 (ADD sz) src dst + SUB sz src dst -> patch2 (SUB sz) src dst + IMUL sz src dst -> patch2 (IMUL sz) src dst + IDIV sz src -> patch1 (IDIV sz) src + AND sz src dst -> patch2 (AND sz) src dst + OR sz src dst -> patch2 (OR sz) src dst + XOR sz src dst -> patch2 (XOR sz) src dst + NOT sz op -> patch1 (NOT sz) op + NEGI sz op -> patch1 (NEGI sz) op + SHL sz imm dst -> patch1 (SHL sz imm) dst + SAR sz imm dst -> patch1 (SAR sz imm) dst + SHR sz imm dst -> patch1 (SHR sz imm) dst + TEST sz src dst -> patch2 (TEST sz) src dst + CMP sz src dst -> patch2 (CMP sz) src dst + PUSH sz op -> patch1 (PUSH sz) op + POP sz op -> patch1 (POP sz) op + SETCC cond op -> patch1 (SETCC cond) op + JMP op -> patch1 JMP op + FADD sz src -> FADD sz (patchOp src) + FIADD sz asrc -> FIADD sz (lookupAddr asrc) + FCOM sz src -> patch1 (FCOM sz) src + FDIV sz src -> FDIV sz (patchOp src) + --FDIVP sz src -> FDIVP sz (patchOp src) + FIDIV sz asrc -> FIDIV sz (lookupAddr asrc) + FDIVR sz src -> FDIVR sz (patchOp src) + --FDIVRP sz src -> FDIVRP sz (patchOp src) + FIDIVR sz asrc -> FIDIVR sz (lookupAddr asrc) + FICOM sz asrc -> FICOM sz (lookupAddr asrc) + FILD sz asrc dst -> FILD sz (lookupAddr asrc) (env dst) + FIST sz adst -> FIST sz (lookupAddr adst) + FLD sz src -> patch1 (FLD sz) (patchOp src) + FMUL sz src -> FMUL sz (patchOp src) + --FMULP sz src -> FMULP sz (patchOp src) + FIMUL sz asrc -> FIMUL sz (lookupAddr asrc) + FST sz dst -> FST sz (patchOp dst) + FSTP sz dst -> FSTP sz (patchOp dst) + FSUB sz src -> FSUB sz (patchOp src) + --FSUBP sz src -> FSUBP sz (patchOp src) + FISUB sz asrc -> FISUB sz (lookupAddr asrc) + FSUBR sz src -> FSUBR sz (patchOp src) + --FSUBRP sz src -> FSUBRP sz (patchOp src) + FISUBR sz asrc -> FISUBR sz (lookupAddr asrc) + FCOMP sz src -> FCOMP sz (patchOp src) + _ -> instr + + where + patch1 insn op = insn (patchOp op) + patch2 insn src dst = insn (patchOp src) (patchOp dst) + + patchOp (OpReg reg) = OpReg (env reg) + patchOp (OpImm imm) = OpImm imm + patchOp (OpAddr ea) = OpAddr (lookupAddr ea) + + lookupAddr (Addr base index disp) + = Addr (lookupBase base) (lookupIndex index) disp + where lookupBase Nothing = Nothing + lookupBase (Just r) = Just (env r) + lookupIndex Nothing = Nothing + lookupIndex (Just (r,i)) = Just (env r, i) + lookupAddr (ImmAddr imm off) + = ImmAddr imm off + +\end{code} + +Sometimes, we want to be able to modify addresses at compile time. +(Okay, just for chrCode of a fetch.) + +\begin{code} + +#ifdef __GLASGOW_HASKELL__ + +{-# SPECIALIZE + is13Bits :: Int -> Bool + #-} +{-# SPECIALIZE + is13Bits :: Integer -> Bool + #-} + +#endif + +is13Bits :: Integral a => a -> Bool +is13Bits x = x >= -4096 && x < 4096 + +offset :: Addr -> Int -> Maybe Addr +offset (Addr reg index (ImmInt n)) off + = Just (Addr reg index (ImmInt n2)) + where n2 = n + off + +offset (Addr reg index (ImmInteger n)) off + = Just (Addr reg index (ImmInt (fromInteger n2))) + where n2 = n + toInteger off + +offset (ImmAddr imm off1) off2 + = Just (ImmAddr imm off3) + where off3 = off1 + off2 + +offset _ _ = Nothing + +\end{code} + +If you value your sanity, do not venture below this line. + +\begin{code} + +-- platform.h is generate and tells us what the target architecture is +#include "../../includes/platform.h" +#define STOLEN_X86_REGS 5 +#include "../../includes/MachRegs.h" +#include "../../includes/i386-unknown-linuxaout.h" + +-- Redefine the literals used for I386 register names in the header +-- files. Gag me with a spoon, eh? + +#define eax 0 +#define ebx 1 +#define ecx 2 +#define edx 3 +#define esi 4 +#define edi 5 +#define ebp 6 +#define esp 7 +#define st0 8 +#define st1 9 +#define st2 10 +#define st3 11 +#define st4 12 +#define st5 13 +#define st6 14 +#define st7 15 +#define CALLER_SAVES_Hp +-- ToDo: rm when we give esp back +#define REG_Hp esp +#define REG_R2 ecx + +baseRegOffset :: MagicId -> Int +baseRegOffset StkOReg = OFFSET_StkO +baseRegOffset (VanillaReg _ ILIT2(1)) = OFFSET_R1 +baseRegOffset (VanillaReg _ ILIT2(2)) = OFFSET_R2 +baseRegOffset (VanillaReg _ ILIT2(3)) = OFFSET_R3 +baseRegOffset (VanillaReg _ ILIT2(4)) = OFFSET_R4 +baseRegOffset (VanillaReg _ ILIT2(5)) = OFFSET_R5 +baseRegOffset (VanillaReg _ ILIT2(6)) = OFFSET_R6 +baseRegOffset (VanillaReg _ ILIT2(7)) = OFFSET_R7 +baseRegOffset (VanillaReg _ ILIT2(8)) = OFFSET_R8 +baseRegOffset (FloatReg ILIT2(1)) = OFFSET_Flt1 +baseRegOffset (FloatReg ILIT2(2)) = OFFSET_Flt2 +baseRegOffset (FloatReg ILIT2(3)) = OFFSET_Flt3 +baseRegOffset (FloatReg ILIT2(4)) = OFFSET_Flt4 +baseRegOffset (DoubleReg ILIT2(1)) = OFFSET_Dbl1 +baseRegOffset (DoubleReg ILIT2(2)) = OFFSET_Dbl2 +baseRegOffset TagReg = OFFSET_Tag +baseRegOffset RetReg = OFFSET_Ret +baseRegOffset SpA = OFFSET_SpA +baseRegOffset SuA = OFFSET_SuA +baseRegOffset SpB = OFFSET_SpB +baseRegOffset SuB = OFFSET_SuB +baseRegOffset Hp = OFFSET_Hp +baseRegOffset HpLim = OFFSET_HpLim +baseRegOffset LivenessReg = OFFSET_Liveness +--baseRegOffset ActivityReg = OFFSET_Activity +#ifdef DEBUG +baseRegOffset BaseReg = panic "baseRegOffset:BaseReg" +baseRegOffset StdUpdRetVecReg = panic "baseRegOffset:StgUpdRetVecReg" +baseRegOffset StkStubReg = panic "baseRegOffset:StkStubReg" +baseRegOffset CurCostCentre = panic "baseRegOffset:CurCostCentre" +baseRegOffset VoidReg = panic "baseRegOffset:VoidReg" +#endif + +callerSaves :: MagicId -> Bool +#ifdef CALLER_SAVES_Base +callerSaves BaseReg = True +#endif +#ifdef CALLER_SAVES_StkO +callerSaves StkOReg = True +#endif +#ifdef CALLER_SAVES_R1 +callerSaves (VanillaReg _ ILIT2(1)) = True +#endif +#ifdef CALLER_SAVES_R2 +callerSaves (VanillaReg _ ILIT2(2)) = True +#endif +#ifdef CALLER_SAVES_R3 +callerSaves (VanillaReg _ ILIT2(3)) = True +#endif +#ifdef CALLER_SAVES_R4 +callerSaves (VanillaReg _ ILIT2(4)) = True +#endif +#ifdef CALLER_SAVES_R5 +callerSaves (VanillaReg _ ILIT2(5)) = True +#endif +#ifdef CALLER_SAVES_R6 +callerSaves (VanillaReg _ ILIT2(6)) = True +#endif +#ifdef CALLER_SAVES_R7 +callerSaves (VanillaReg _ ILIT2(7)) = True +#endif +#ifdef CALLER_SAVES_R8 +callerSaves (VanillaReg _ ILIT2(8)) = True +#endif +#ifdef CALLER_SAVES_FltReg1 +callerSaves (FloatReg ILIT2(1)) = True +#endif +#ifdef CALLER_SAVES_FltReg2 +callerSaves (FloatReg ILIT2(2)) = True +#endif +#ifdef CALLER_SAVES_FltReg3 +callerSaves (FloatReg ILIT2(3)) = True +#endif +#ifdef CALLER_SAVES_FltReg4 +callerSaves (FloatReg ILIT2(4)) = True +#endif +#ifdef CALLER_SAVES_DblReg1 +callerSaves (DoubleReg ILIT2(1)) = True +#endif +#ifdef CALLER_SAVES_DblReg2 +callerSaves (DoubleReg ILIT2(2)) = True +#endif +#ifdef CALLER_SAVES_Tag +callerSaves TagReg = True +#endif +#ifdef CALLER_SAVES_Ret +callerSaves RetReg = True +#endif +#ifdef CALLER_SAVES_SpA +callerSaves SpA = True +#endif +#ifdef CALLER_SAVES_SuA +callerSaves SuA = True +#endif +#ifdef CALLER_SAVES_SpB +callerSaves SpB = True +#endif +#ifdef CALLER_SAVES_SuB +callerSaves SuB = True +#endif +#ifdef CALLER_SAVES_Hp +callerSaves Hp = True +#endif +#ifdef CALLER_SAVES_HpLim +callerSaves HpLim = True +#endif +#ifdef CALLER_SAVES_Liveness +callerSaves LivenessReg = True +#endif +#ifdef CALLER_SAVES_Activity +--callerSaves ActivityReg = True +#endif +#ifdef CALLER_SAVES_StdUpdRetVec +callerSaves StdUpdRetVecReg = True +#endif +#ifdef CALLER_SAVES_StkStub +callerSaves StkStubReg = True +#endif +callerSaves _ = False + +stgRegMap :: MagicId -> Maybe Reg + +#ifdef REG_Base +stgRegMap BaseReg = Just (FixedReg ILIT(REG_Base)) +#endif +#ifdef REG_StkO +stgRegMap StkOReg = Just (FixedReg ILIT(REG_StkOReg)) +#endif +#ifdef REG_R1 +stgRegMap (VanillaReg _ ILIT2(1)) = Just (FixedReg ILIT(REG_R1)) +#endif +#ifdef REG_R2 +stgRegMap (VanillaReg _ ILIT2(2)) = Just (FixedReg ILIT(REG_R2)) +#endif +#ifdef REG_R3 +stgRegMap (VanillaReg _ ILIT2(3)) = Just (FixedReg ILIT(REG_R3)) +#endif +#ifdef REG_R4 +stgRegMap (VanillaReg _ ILIT2(4)) = Just (FixedReg ILIT(REG_R4)) +#endif +#ifdef REG_R5 +stgRegMap (VanillaReg _ ILIT2(5)) = Just (FixedReg ILIT(REG_R5)) +#endif +#ifdef REG_R6 +stgRegMap (VanillaReg _ ILIT2(6)) = Just (FixedReg ILIT(REG_R6)) +#endif +#ifdef REG_R7 +stgRegMap (VanillaReg _ ILIT2(7)) = Just (FixedReg ILIT(REG_R7)) +#endif +#ifdef REG_R8 +stgRegMap (VanillaReg _ ILIT2(8)) = Just (FixedReg ILIT(REG_R8)) +#endif +#ifdef REG_Flt1 +stgRegMap (FloatReg ILIT2(1)) = Just (FixedReg ILIT(REG_Flt1)) +#endif +#ifdef REG_Flt2 +stgRegMap (FloatReg ILIT2(2)) = Just (FixedReg ILIT(REG_Flt2)) +#endif +#ifdef REG_Flt3 +stgRegMap (FloatReg ILIT2(3)) = Just (FixedReg ILIT(REG_Flt3)) +#endif +#ifdef REG_Flt4 +stgRegMap (FloatReg ILIT2(4)) = Just (FixedReg ILIT(REG_Flt4)) +#endif +#ifdef REG_Dbl1 +stgRegMap (DoubleReg ILIT2(1)) = Just (FixedReg ILIT(REG_Dbl1)) +#endif +#ifdef REG_Dbl2 +stgRegMap (DoubleReg ILIT2(2)) = Just (FixedReg ILIT(REG_Dbl2)) +#endif +#ifdef REG_Tag +stgRegMap TagReg = Just (FixedReg ILIT(REG_TagReg)) +#endif +#ifdef REG_Ret +stgRegMap RetReg = Just (FixedReg ILIT(REG_Ret)) +#endif +#ifdef REG_SpA +stgRegMap SpA = Just (FixedReg ILIT(REG_SpA)) +#endif +#ifdef REG_SuA +stgRegMap SuA = Just (FixedReg ILIT(REG_SuA)) +#endif +#ifdef REG_SpB +stgRegMap SpB = Just (FixedReg ILIT(REG_SpB)) +#endif +#ifdef REG_SuB +stgRegMap SuB = Just (FixedReg ILIT(REG_SuB)) +#endif +#ifdef REG_Hp +stgRegMap Hp = Just (FixedReg ILIT(REG_Hp)) +#endif +#ifdef REG_HpLim +stgRegMap HpLim = Just (FixedReg ILIT(REG_HpLim)) +#endif +#ifdef REG_Liveness +stgRegMap LivenessReg = Just (FixedReg ILIT(REG_Liveness)) +#endif +#ifdef REG_Activity +--stgRegMap ActivityReg = Just (FixedReg ILIT(REG_Activity)) +#endif +#ifdef REG_StdUpdRetVec +stgRegMap StdUpdRetVecReg = Just (FixedReg ILIT(REG_StdUpdRetVec)) +#endif +#ifdef REG_StkStub +stgRegMap StkStubReg = Just (FixedReg ILIT(REG_StkStub)) +#endif + +stgRegMap _ = Nothing + +\end{code} + +Here is the list of registers we can use in register allocation. + +\begin{code} +freeReg :: FAST_INT -> FAST_BOOL + +--freeReg ILIT(esp) = _FALSE_ -- %esp is our stack pointer. + +#ifdef REG_Base +freeReg ILIT(REG_Base) = _FALSE_ +#endif +#ifdef REG_StkO +freeReg ILIT(REG_StkO) = _FALSE_ +#endif +#ifdef REG_R1 +freeReg ILIT(REG_R1) = _FALSE_ +#endif +#ifdef REG_R2 +freeReg ILIT(REG_R2) = _FALSE_ +#endif +#ifdef REG_R3 +freeReg ILIT(REG_R3) = _FALSE_ +#endif +#ifdef REG_R4 +freeReg ILIT(REG_R4) = _FALSE_ +#endif +#ifdef REG_R5 +freeReg ILIT(REG_R5) = _FALSE_ +#endif +#ifdef REG_R6 +freeReg ILIT(REG_R6) = _FALSE_ +#endif +#ifdef REG_R7 +freeReg ILIT(REG_R7) = _FALSE_ +#endif +#ifdef REG_R8 +freeReg ILIT(REG_R8) = _FALSE_ +#endif +#ifdef REG_Flt1 +freeReg ILIT(REG_Flt1) = _FALSE_ +#endif +#ifdef REG_Flt2 +freeReg ILIT(REG_Flt2) = _FALSE_ +#endif +#ifdef REG_Flt3 +freeReg ILIT(REG_Flt3) = _FALSE_ +#endif +#ifdef REG_Flt4 +freeReg ILIT(REG_Flt4) = _FALSE_ +#endif +#ifdef REG_Dbl1 +freeReg ILIT(REG_Dbl1) = _FALSE_ +#endif +#ifdef REG_Dbl2 +freeReg ILIT(REG_Dbl2) = _FALSE_ +#endif +#ifdef REG_Tag +freeReg ILIT(REG_Tag) = _FALSE_ +#endif +#ifdef REG_Ret +freeReg ILIT(REG_Ret) = _FALSE_ +#endif +#ifdef REG_SpA +freeReg ILIT(REG_SpA) = _FALSE_ +#endif +#ifdef REG_SuA +freeReg ILIT(REG_SuA) = _FALSE_ +#endif +#ifdef REG_SpB +freeReg ILIT(REG_SpB) = _FALSE_ +#endif +#ifdef REG_SuB +freeReg ILIT(REG_SuB) = _FALSE_ +#endif +#ifdef REG_Hp +freeReg ILIT(REG_Hp) = _FALSE_ +#endif +#ifdef REG_HpLim +freeReg ILIT(REG_HpLim) = _FALSE_ +#endif +#ifdef REG_Liveness +freeReg ILIT(REG_Liveness) = _FALSE_ +#endif +#ifdef REG_Activity +--freeReg ILIT(REG_Activity) = _FALSE_ +#endif +#ifdef REG_StdUpdRetVec +freeReg ILIT(REG_StdUpdRetVec) = _FALSE_ +#endif +#ifdef REG_StkStub +freeReg ILIT(REG_StkStub) = _FALSE_ +#endif +freeReg n +#ifdef REG_Dbl1 + | n _EQ_ (ILIT(REG_Dbl1) _ADD_ ILIT(1)) = _FALSE_ +#endif +#ifdef REG_Dbl2 + | n _EQ_ (ILIT(REG_Dbl2) _ADD_ ILIT(1)) = _FALSE_ +#endif + + | otherwise = _TRUE_ + +reservedRegs :: [Int] +reservedRegs = [] +--reservedRegs = [NCG_Reserved_I1, NCG_Reserved_I2, +-- NCG_Reserved_F1, NCG_Reserved_F2, +-- NCG_Reserved_D1, NCG_Reserved_D2] + +\end{code} + diff --git a/ghc/compiler/nativeGen/I386Desc.hi b/ghc/compiler/nativeGen/I386Desc.hi new file mode 100644 index 0000000000..ef711c7e58 --- /dev/null +++ b/ghc/compiler/nativeGen/I386Desc.hi @@ -0,0 +1,25 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface I386Desc where +import AbsCSyn(MagicId) +import CLabelInfo(CLabel) +import CharSeq(CSeq) +import CmdLineOpts(GlobalSwitch, SwitchResult) +import MachDesc(RegLoc, Target) +import PreludePS(_PackedString) +import PreludeRatio(Ratio(..)) +import Pretty(PprStyle) +import PrimKind(PrimKind) +import PrimOps(PrimOp) +import SMRep(SMRep, SMSpecRepKind, SMUpdateKind) +import SplitUniq(SplitUniqSupply) +import Stix(CodeSegment, StixReg, StixTree) +data MagicId {-# GHC_PRAGMA BaseReg | StkOReg | VanillaReg PrimKind Int# | FloatReg Int# | DoubleReg Int# | TagReg | RetReg | SpA | SuA | SpB | SuB | Hp | HpLim | LivenessReg | ActivityReg | StdUpdRetVecReg | StkStubReg | CurCostCentre | VoidReg #-} +data SwitchResult {-# GHC_PRAGMA SwBool Bool | SwString [Char] | SwInt Int #-} +data RegLoc {-# GHC_PRAGMA Save StixTree | Always StixTree #-} +data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-} +data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-} +data SMRep {-# GHC_PRAGMA StaticRep Int Int | SpecialisedRep SMSpecRepKind Int Int SMUpdateKind | GenericRep Int Int SMUpdateKind | BigTupleRep Int | DataRep Int | DynamicRep | BlackHoleRep | PhantomRep | MuTupleRep Int #-} +data StixTree {-# GHC_PRAGMA StSegment CodeSegment | StInt Integer | StDouble (Ratio Integer) | StString _PackedString | StLitLbl CSeq | StLitLit _PackedString | StCLbl CLabel | StReg StixReg | StIndex PrimKind StixTree StixTree | StInd PrimKind StixTree | StAssign PrimKind StixTree StixTree | StLabel CLabel | StFunBegin CLabel | StFunEnd CLabel | StJump StixTree | StFallThrough CLabel | StCondJump CLabel StixTree | StData PrimKind [StixTree] | StPrim PrimOp [StixTree] | StCall _PackedString PrimKind [StixTree] | StComment _PackedString #-} +mkI386 :: Bool -> (GlobalSwitch -> SwitchResult) -> (Target, PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq, Bool, [Char] -> [Char]) + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/nativeGen/I386Desc.lhs b/ghc/compiler/nativeGen/I386Desc.lhs new file mode 100644 index 0000000000..402cdc0f87 --- /dev/null +++ b/ghc/compiler/nativeGen/I386Desc.lhs @@ -0,0 +1,204 @@ +% +% (c) The AQUA Project, Glasgow University, 1994-1995 +% +\section[I386Desc]{The I386 Machine Description} + +\begin{code} +#include "HsVersions.h" + +module I386Desc ( + mkI386, + + -- and assorted nonsense referenced by the class methods + + PprStyle, SMRep, MagicId, RegLoc, StixTree, PrimKind, SwitchResult + + ) where + +import AbsCSyn +import AbsPrel ( PrimOp(..) + IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) + IF_ATTACK_PRAGMAS(COMMA pprPrimOp) + ) +import AsmRegAlloc ( Reg, MachineCode(..), MachineRegisters(..), + RegLiveness(..), RegUsage(..), FutureLive(..) + ) +import CLabelInfo ( CLabel ) +import CmdLineOpts ( GlobalSwitch(..), stringSwitchSet, switchIsOn, SwitchResult(..) ) +import HeapOffs ( hpRelToInt ) +import MachDesc +import Maybes ( Maybe(..) ) +import OrdList +import Outputable +import PrimKind ( PrimKind(..) ) +import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) ) +import I386Code +import I386Gen ( i386CodeGen ) +import Stix +import StixMacro +import StixPrim +import SplitUniq +import Unique +import Util + +\end{code} + +Header sizes depend only on command-line options, not on the target +architecture. (I think.) + +\begin{code} + +fhs :: (GlobalSwitch -> SwitchResult) -> Int + +fhs switches = 1 + profFHS + ageFHS + where + profFHS = if switchIsOn switches SccProfilingOn then 1 else 0 + ageFHS = if switchIsOn switches SccProfilingOn then 1 else 0 + +vhs :: (GlobalSwitch -> SwitchResult) -> SMRep -> Int + +vhs switches sm = case sm of + StaticRep _ _ -> 0 + SpecialisedRep _ _ _ _ -> 0 + GenericRep _ _ _ -> 0 + BigTupleRep _ -> 1 + MuTupleRep _ -> 2 {- (1 + GC_MUT_RESERVED_WORDS) -} + DataRep _ -> 1 + DynamicRep -> 2 + BlackHoleRep -> 0 + PhantomRep -> panic "vhs:phantom" + +\end{code} + +Here we map STG registers onto appropriate Stix Trees. First, we +handle the two constants, @STK_STUB_closure@ and @vtbl_StdUpdFrame@. +The rest are either in real machine registers or stored as offsets +from BaseReg. + +\begin{code} + +i386Reg :: (GlobalSwitch -> SwitchResult) -> MagicId -> RegLoc + +i386Reg switches x = + case stgRegMap x of + Just reg -> Save nonReg + Nothing -> Always nonReg + where nonReg = case x of + StkStubReg -> sStLitLbl SLIT("STK_STUB_closure") + StdUpdRetVecReg -> sStLitLbl SLIT("vtbl_StdUpdFrame") + BaseReg -> sStLitLbl SLIT("MainRegTable") + --Hp -> StInd PtrKind (sStLitLbl SLIT("StorageMgrInfo")) + --HpLim -> StInd PtrKind (sStLitLbl SLIT("StorageMgrInfo+4")) + TagReg -> StInd IntKind (StPrim IntSubOp [infoptr, StInt (1*4)]) + where + r2 = VanillaReg PtrKind ILIT(2) + infoptr = case i386Reg switches r2 of + Always tree -> tree + Save _ -> StReg (StixMagicId r2) + _ -> StInd (kindFromMagicId x) + (StPrim IntAddOp [baseLoc, StInt (toInteger (offset*4))]) + baseLoc = case stgRegMap BaseReg of + Just _ -> StReg (StixMagicId BaseReg) + Nothing -> sStLitLbl SLIT("MainRegTable") + offset = baseRegOffset x + +\end{code} + +Sizes in bytes. + +\begin{code} + +size pk = case kindToSize pk of + {B -> 1; S -> 2; L -> 4; F -> 4; D -> 8 } + +\end{code} + +Now the volatile saves and restores. We add the basic guys to the list of ``user'' +registers provided. Note that there are more basic registers on the restore list, +because some are reloaded from constants. + +\begin{code} + +vsaves switches vols = + map save ((filter callerSaves) ([BaseReg,SpA,SuA,SpB,SuB,Hp,HpLim,RetReg{-,ActivityReg-}] ++ vols)) + where + save x = StAssign (kindFromMagicId x) loc reg + where reg = StReg (StixMagicId x) + loc = case i386Reg switches x of + Save loc -> loc + Always loc -> panic "vsaves" + +vrests switches vols = + map restore ((filter callerSaves) + ([BaseReg,SpA,SuA,SpB,SuB,Hp,HpLim,RetReg{-,ActivityReg-},StkStubReg,StdUpdRetVecReg] ++ vols)) + where + restore x = StAssign (kindFromMagicId x) reg loc + where reg = StReg (StixMagicId x) + loc = case i386Reg switches x of + Save loc -> loc + Always loc -> panic "vrests" + +\end{code} + +Static closure sizes. + +\begin{code} + +charLikeSize, intLikeSize :: Target -> Int + +charLikeSize target = + size PtrKind * (fixedHeaderSize target + varHeaderSize target charLikeRep + 1) + where charLikeRep = SpecialisedRep CharLikeRep 0 1 SMNormalForm + +intLikeSize target = + size PtrKind * (fixedHeaderSize target + varHeaderSize target intLikeRep + 1) + where intLikeRep = SpecialisedRep IntLikeRep 0 1 SMNormalForm + +mhs, dhs :: (GlobalSwitch -> SwitchResult) -> StixTree + +mhs switches = StInt (toInteger words) + where + words = fhs switches + vhs switches (MuTupleRep 0) + +dhs switches = StInt (toInteger words) + where + words = fhs switches + vhs switches (DataRep 0) + +\end{code} + +Setting up a i386 target. + +\begin{code} +mkI386 :: Bool + -> (GlobalSwitch -> SwitchResult) + -> (Target, + (PprStyle -> [[StixTree]] -> SUniqSM Unpretty), -- codeGen + Bool, -- underscore + (String -> String)) -- fmtAsmLbl + +mkI386 decentOS switches = + let fhs' = fhs switches + vhs' = vhs switches + i386Reg' = i386Reg switches + vsaves' = vsaves switches + vrests' = vrests switches + hprel = hpRelToInt target + as = amodeCode target + as' = amodeCode' target + csz = charLikeSize target + isz = intLikeSize target + mhs' = mhs switches + dhs' = dhs switches + ps = genPrimCode target + mc = genMacroCode target + hc = doHeapCheck --UNUSED NOW: target + target = mkTarget {-switches-} fhs' vhs' i386Reg' {-id-} size + hprel as as' + (vsaves', vrests', csz, isz, mhs', dhs', ps, mc, hc) + {-i386CodeGen decentOS id-} + in + (target, i386CodeGen, decentOS, id) +\end{code} + + + diff --git a/ghc/compiler/nativeGen/I386Gen.hi b/ghc/compiler/nativeGen/I386Gen.hi new file mode 100644 index 0000000000..41a8681477 --- /dev/null +++ b/ghc/compiler/nativeGen/I386Gen.hi @@ -0,0 +1,18 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface I386Gen where +import CLabelInfo(CLabel) +import CharSeq(CSeq) +import CmdLineOpts(GlobalSwitch) +import PreludePS(_PackedString) +import PreludeRatio(Ratio(..)) +import Pretty(PprStyle) +import PrimKind(PrimKind) +import PrimOps(PrimOp) +import SplitUniq(SplitUniqSupply) +import Stix(CodeSegment, StixReg, StixTree) +data CSeq {-# GHC_PRAGMA CNil | CAppend CSeq CSeq | CIndent Int CSeq | CNewline | CStr [Char] | CCh Char | CInt Int | CPStr _PackedString #-} +data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-} +data StixTree {-# GHC_PRAGMA StSegment CodeSegment | StInt Integer | StDouble (Ratio Integer) | StString _PackedString | StLitLbl CSeq | StLitLit _PackedString | StCLbl CLabel | StReg StixReg | StIndex PrimKind StixTree StixTree | StInd PrimKind StixTree | StAssign PrimKind StixTree StixTree | StLabel CLabel | StFunBegin CLabel | StFunEnd CLabel | StJump StixTree | StFallThrough CLabel | StCondJump CLabel StixTree | StData PrimKind [StixTree] | StPrim PrimOp [StixTree] | StCall _PackedString PrimKind [StixTree] | StComment _PackedString #-} +i386CodeGen :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq + {-# GHC_PRAGMA _A_ 2 _U_ 211 _N_ _S_ "LS" _N_ _N_ #-} + diff --git a/ghc/compiler/nativeGen/I386Gen.lhs b/ghc/compiler/nativeGen/I386Gen.lhs new file mode 100644 index 0000000000..8f0d191b2c --- /dev/null +++ b/ghc/compiler/nativeGen/I386Gen.lhs @@ -0,0 +1,1653 @@ +% +% (c) The AQUA Project, Glasgow University, 1993-1995 +% + +\begin{code} +#include "HsVersions.h" +#include "../includes/i386-unknown-linuxaout.h" + +module I386Gen ( + i386CodeGen, + + -- and, for self-sufficiency + PprStyle, StixTree, CSeq + ) where + +IMPORT_Trace + +import AbsCSyn ( AbstractC, MagicId(..), kindFromMagicId ) +import AbsPrel ( PrimOp(..) + IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) + IF_ATTACK_PRAGMAS(COMMA pprPrimOp) + ) +import AsmRegAlloc ( runRegAllocate, mkReg, extractMappedRegNos, + Reg(..), RegLiveness(..), RegUsage(..), + FutureLive(..), MachineRegisters(..), MachineCode(..) + ) +import CLabelInfo ( CLabel, isAsmTemp ) +import I386Code {- everything -} +import MachDesc +import Maybes ( maybeToBool, Maybe(..) ) +import OrdList -- ( mkEmptyList, mkUnitList, mkSeqList, mkParList, OrdList ) +import Outputable +import PrimKind ( PrimKind(..), isFloatingKind ) +import I386Desc +import Stix +import SplitUniq +import Unique +import Pretty +import Unpretty +import Util + +type CodeBlock a = (OrdList a -> OrdList a) + +\end{code} + +%************************************************************************ +%* * +\subsection[I386CodeGen]{Generating I386 Code} +%* * +%************************************************************************ + +This is the top-level code-generation function for the I386. + +\begin{code} + +i386CodeGen :: PprStyle -> [[StixTree]] -> SUniqSM Unpretty +i386CodeGen sty trees = + mapSUs genI386Code trees `thenSUs` \ dynamicCodes -> + let + staticCodes = scheduleI386Code dynamicCodes + pretty = printLabeledCodes sty staticCodes + in + returnSUs pretty + +\end{code} + +This bit does the code scheduling. The scheduler must also deal with +register allocation of temporaries. Much parallelism can be exposed via +the OrdList, but more might occur, so further analysis might be needed. + +\begin{code} + +scheduleI386Code :: [I386Code] -> [I386Instr] +scheduleI386Code = concat . map (runRegAllocate freeI386Regs reservedRegs) + where + freeI386Regs :: I386Regs + freeI386Regs = mkMRegs (extractMappedRegNos freeRegs) + + +\end{code} + +Registers passed up the tree. If the stix code forces the register +to live in a pre-decided machine register, it comes out as @Fixed@; +otherwise, it comes out as @Any@, and the parent can decide which +register to put it in. + +\begin{code} + +data Register + = Fixed Reg PrimKind (CodeBlock I386Instr) + | Any PrimKind (Reg -> (CodeBlock I386Instr)) + +registerCode :: Register -> Reg -> CodeBlock I386Instr +registerCode (Fixed _ _ code) reg = code +registerCode (Any _ code) reg = code reg + +registerName :: Register -> Reg -> Reg +registerName (Fixed reg _ _) _ = reg +registerName (Any _ _) reg = reg + +registerKind :: Register -> PrimKind +registerKind (Fixed _ pk _) = pk +registerKind (Any pk _) = pk + +isFixed :: Register -> Bool +isFixed (Fixed _ _ _) = True +isFixed (Any _ _) = False + +\end{code} + +Memory addressing modes passed up the tree. + +\begin{code} + +data Amode = Amode Addr (CodeBlock I386Instr) + +amodeAddr (Amode addr _) = addr +amodeCode (Amode _ code) = code + +\end{code} + +Condition codes passed up the tree. + +\begin{code} + +data Condition = Condition Bool Cond (CodeBlock I386Instr) + +condName (Condition _ cond _) = cond +condFloat (Condition float _ _) = float +condCode (Condition _ _ code) = code + +\end{code} + +General things for putting together code sequences. + +\begin{code} + +asmVoid :: OrdList I386Instr +asmVoid = mkEmptyList + +asmInstr :: I386Instr -> I386Code +asmInstr i = mkUnitList i + +asmSeq :: [I386Instr] -> I386Code +asmSeq is = foldr (mkSeqList . asmInstr) asmVoid is + +asmParThen :: [I386Code] -> (CodeBlock I386Instr) +asmParThen others code = mkSeqList (foldr mkParList mkEmptyList others) code + +returnInstr :: I386Instr -> SUniqSM (CodeBlock I386Instr) +returnInstr instr = returnSUs (\xs -> mkSeqList (asmInstr instr) xs) + +returnInstrs :: [I386Instr] -> SUniqSM (CodeBlock I386Instr) +returnInstrs instrs = returnSUs (\xs -> mkSeqList (asmSeq instrs) xs) + +returnSeq :: (CodeBlock I386Instr) -> [I386Instr] -> SUniqSM (CodeBlock I386Instr) +returnSeq code instrs = returnSUs (\xs -> code (mkSeqList (asmSeq instrs) xs)) + +mkSeqInstr :: I386Instr -> (CodeBlock I386Instr) +mkSeqInstr instr code = mkSeqList (asmInstr instr) code + +mkSeqInstrs :: [I386Instr] -> (CodeBlock I386Instr) +mkSeqInstrs instrs code = mkSeqList (asmSeq instrs) code + +\end{code} + +Top level i386 code generator for a chunk of stix code. + +\begin{code} + +genI386Code :: [StixTree] -> SUniqSM (I386Code) + +genI386Code trees = + mapSUs getCode trees `thenSUs` \ blocks -> + returnSUs (foldr (.) id blocks asmVoid) + +\end{code} + +Code extractor for an entire stix tree---stix statement level. + +\begin{code} + +getCode + :: StixTree -- a stix statement + -> SUniqSM (CodeBlock I386Instr) + +getCode (StSegment seg) = returnInstr (SEGMENT seg) + +getCode (StAssign pk dst src) + | isFloatingKind pk = assignFltCode pk dst src + | otherwise = assignIntCode pk dst src + +getCode (StLabel lab) = returnInstr (LABEL lab) + +getCode (StFunBegin lab) = returnInstr (LABEL lab) + +getCode (StFunEnd lab) = returnSUs id + +getCode (StJump arg) = genJump arg + +getCode (StFallThrough lbl) = returnSUs id + +getCode (StCondJump lbl arg) = genCondJump lbl arg + +getCode (StData kind args) = + mapAndUnzipSUs getData args `thenSUs` \ (codes, imms) -> + returnSUs (\xs -> mkSeqList (asmInstr (DATA (kindToSize kind) imms)) + (foldr1 (.) codes xs)) + where + getData :: StixTree -> SUniqSM (CodeBlock I386Instr, Imm) + getData (StInt i) = returnSUs (id, ImmInteger i) +#if __GLASGOW_HASKELL__ >= 23 +-- getData (StDouble d) = returnSUs (id, strImmLit ('0' : 'd' : _showRational 30 d)) + -- yurgh (WDP 94/12) + getData (StDouble d) = returnSUs (id, strImmLit ('0' : 'd' : ppShow 80 (ppRational d))) +#else + getData (StDouble d) = returnSUs (id, strImmLit ('0' : 'd' : show d)) +#endif + getData (StLitLbl s) = returnSUs (id, ImmLit (uppBeside (uppChar '_') s)) + getData (StLitLit s) = returnSUs (id, strImmLit (cvtLitLit (_UNPK_ s))) + getData (StString s) = + getUniqLabelNCG `thenSUs` \ lbl -> + returnSUs (mkSeqInstrs [LABEL lbl, ASCII True (_UNPK_ s)], ImmCLbl lbl) + getData (StCLbl l) = returnSUs (id, ImmCLbl l) + +getCode (StCall fn VoidKind args) = genCCall fn VoidKind args + +getCode (StComment s) = returnInstr (COMMENT s) + +\end{code} + +Generate code to get a subtree into a register. + +\begin{code} + +getReg :: StixTree -> SUniqSM Register + +getReg (StReg (StixMagicId stgreg)) = + case stgRegMap stgreg of + Just reg -> returnSUs (Fixed reg (kindFromMagicId stgreg) id) + -- cannot be Nothing + +getReg (StReg (StixTemp u pk)) = returnSUs (Fixed (UnmappedReg u pk) pk id) + +getReg (StDouble 0.0) + = let + code dst = mkSeqInstrs [FLDZ] + in + returnSUs (Any DoubleKind code) + +getReg (StDouble 1.0) + = let + code dst = mkSeqInstrs [FLD1] + in + returnSUs (Any DoubleKind code) + +getReg (StDouble d) = + getUniqLabelNCG `thenSUs` \ lbl -> + --getNewRegNCG PtrKind `thenSUs` \ tmp -> + let code dst = mkSeqInstrs [ + SEGMENT DataSegment, + LABEL lbl, +#if __GLASGOW_HASKELL__ >= 23 +-- DATA D [strImmLit ('0' : 'd' :_showRational 30 d)], + DATA D [strImmLit ('0' : 'd' :ppShow 80 (ppRational d))], +#else + DATA D [strImmLit ('0' : 'd' :show d)], +#endif + SEGMENT TextSegment, + FLD D (OpImm (ImmCLbl lbl)) + ] + in + returnSUs (Any DoubleKind code) + +getReg (StString s) = + getUniqLabelNCG `thenSUs` \ lbl -> + let code dst = mkSeqInstrs [ + SEGMENT DataSegment, + LABEL lbl, + ASCII True (_UNPK_ s), + SEGMENT TextSegment, + MOV L (OpImm (ImmCLbl lbl)) (OpReg dst)] + in + returnSUs (Any PtrKind code) + +getReg (StLitLit s) | _HEAD_ s == '"' && last xs == '"' = + getUniqLabelNCG `thenSUs` \ lbl -> + let code dst = mkSeqInstrs [ + SEGMENT DataSegment, + LABEL lbl, + ASCII False (init xs), + SEGMENT TextSegment, + MOV L (OpImm (ImmCLbl lbl)) (OpReg dst)] + in + returnSUs (Any PtrKind code) + where + xs = _UNPK_ (_TAIL_ s) + + +getReg tree@(StIndex _ _ _) = getReg (mangleIndexTree tree) + +getReg (StCall fn kind args) = + genCCall fn kind args `thenSUs` \ call -> + returnSUs (Fixed reg kind call) + where + reg = if isFloatingKind kind then st0 else eax + +getReg (StPrim primop args) = + case primop of + + CharGtOp -> condIntReg GT args + CharGeOp -> condIntReg GE args + CharEqOp -> condIntReg EQ args + CharNeOp -> condIntReg NE args + CharLtOp -> condIntReg LT args + CharLeOp -> condIntReg LE args + + IntAddOp -> -- this should be optimised by the generic Opts, + -- I don't know why it is not (sometimes)! + case args of + [x, StInt 0] -> getReg x + _ -> addCode L args + + IntSubOp -> subCode L args + IntMulOp -> trivialCode (IMUL L) args True + IntQuotOp -> divCode L args True -- division + IntRemOp -> divCode L args False -- remainder + IntNegOp -> trivialUCode (NEGI L) args + IntAbsOp -> absIntCode args + + AndOp -> trivialCode (AND L) args True + OrOp -> trivialCode (OR L) args True + NotOp -> trivialUCode (NOT L) args + SllOp -> trivialCode (SHL L) args False + SraOp -> trivialCode (SAR L) args False + SrlOp -> trivialCode (SHR L) args False + ISllOp -> panic "I386Gen:isll" + ISraOp -> panic "I386Gen:isra" + ISrlOp -> panic "I386Gen:isrl" + + IntGtOp -> condIntReg GT args + IntGeOp -> condIntReg GE args + IntEqOp -> condIntReg EQ args + IntNeOp -> condIntReg NE args + IntLtOp -> condIntReg LT args + IntLeOp -> condIntReg LE args + + WordGtOp -> condIntReg GU args + WordGeOp -> condIntReg GEU args + WordEqOp -> condIntReg EQ args + WordNeOp -> condIntReg NE args + WordLtOp -> condIntReg LU args + WordLeOp -> condIntReg LEU args + + AddrGtOp -> condIntReg GU args + AddrGeOp -> condIntReg GEU args + AddrEqOp -> condIntReg EQ args + AddrNeOp -> condIntReg NE args + AddrLtOp -> condIntReg LU args + AddrLeOp -> condIntReg LEU args + + FloatAddOp -> trivialFCode FloatKind FADD FADD FADDP FADDP args + FloatSubOp -> trivialFCode FloatKind FSUB FSUBR FSUBP FSUBRP args + FloatMulOp -> trivialFCode FloatKind FMUL FMUL FMULP FMULP args + FloatDivOp -> trivialFCode FloatKind FDIV FDIVR FDIVP FDIVRP args + FloatNegOp -> trivialUFCode FloatKind FCHS args + + FloatGtOp -> condFltReg GT args + FloatGeOp -> condFltReg GE args + FloatEqOp -> condFltReg EQ args + FloatNeOp -> condFltReg NE args + FloatLtOp -> condFltReg LT args + FloatLeOp -> condFltReg LE args + + FloatExpOp -> promoteAndCall SLIT("exp") DoubleKind + FloatLogOp -> promoteAndCall SLIT("log") DoubleKind + FloatSqrtOp -> trivialUFCode FloatKind FSQRT args + + FloatSinOp -> promoteAndCall SLIT("sin") DoubleKind + --trivialUFCode FloatKind FSIN args + FloatCosOp -> promoteAndCall SLIT("cos") DoubleKind + --trivialUFCode FloatKind FCOS args + FloatTanOp -> promoteAndCall SLIT("tan") DoubleKind + + FloatAsinOp -> promoteAndCall SLIT("asin") DoubleKind + FloatAcosOp -> promoteAndCall SLIT("acos") DoubleKind + FloatAtanOp -> promoteAndCall SLIT("atan") DoubleKind + + FloatSinhOp -> promoteAndCall SLIT("sinh") DoubleKind + FloatCoshOp -> promoteAndCall SLIT("cosh") DoubleKind + FloatTanhOp -> promoteAndCall SLIT("tanh") DoubleKind + + FloatPowerOp -> promoteAndCall SLIT("pow") DoubleKind + + DoubleAddOp -> trivialFCode DoubleKind FADD FADD FADDP FADDP args + DoubleSubOp -> trivialFCode DoubleKind FSUB FSUBR FSUBP FSUBRP args + DoubleMulOp -> trivialFCode DoubleKind FMUL FMUL FMULP FMULP args + DoubleDivOp -> trivialFCode DoubleKind FDIV FDIVR FDIVP FDIVRP args + DoubleNegOp -> trivialUFCode DoubleKind FCHS args + + DoubleGtOp -> condFltReg GT args + DoubleGeOp -> condFltReg GE args + DoubleEqOp -> condFltReg EQ args + DoubleNeOp -> condFltReg NE args + DoubleLtOp -> condFltReg LT args + DoubleLeOp -> condFltReg LE args + + DoubleExpOp -> call SLIT("exp") DoubleKind + DoubleLogOp -> call SLIT("log") DoubleKind + DoubleSqrtOp -> trivialUFCode DoubleKind FSQRT args + + DoubleSinOp -> call SLIT("sin") DoubleKind + --trivialUFCode DoubleKind FSIN args + DoubleCosOp -> call SLIT("cos") DoubleKind + --trivialUFCode DoubleKind FCOS args + DoubleTanOp -> call SLIT("tan") DoubleKind + + DoubleAsinOp -> call SLIT("asin") DoubleKind + DoubleAcosOp -> call SLIT("acos") DoubleKind + DoubleAtanOp -> call SLIT("atan") DoubleKind + + DoubleSinhOp -> call SLIT("sinh") DoubleKind + DoubleCoshOp -> call SLIT("cosh") DoubleKind + DoubleTanhOp -> call SLIT("tanh") DoubleKind + + DoublePowerOp -> call SLIT("pow") DoubleKind + + OrdOp -> coerceIntCode IntKind args + ChrOp -> chrCode args + + Float2IntOp -> coerceFP2Int args + Int2FloatOp -> coerceInt2FP FloatKind args + Double2IntOp -> coerceFP2Int args + Int2DoubleOp -> coerceInt2FP DoubleKind args + + Double2FloatOp -> coerceFltCode args + Float2DoubleOp -> coerceFltCode args + + where + call fn pk = getReg (StCall fn pk args) + promoteAndCall fn pk = getReg (StCall fn pk (map promote args)) + where + promote x = StPrim Float2DoubleOp [x] + +getReg (StInd pk mem) = + getAmode mem `thenSUs` \ amode -> + let + code = amodeCode amode + src = amodeAddr amode + size = kindToSize pk + code__2 dst = code . + if pk == DoubleKind || pk == FloatKind + then mkSeqInstr (FLD {-D-} size (OpAddr src)) + else mkSeqInstr (MOV size (OpAddr src) (OpReg dst)) + in + returnSUs (Any pk code__2) + + +getReg (StInt i) + = let + src = ImmInt (fromInteger i) + code dst = mkSeqInstr (MOV L (OpImm src) (OpReg dst)) + in + returnSUs (Any IntKind code) + +getReg leaf + | maybeToBool imm = + let + code dst = mkSeqInstr (MOV L (OpImm imm__2) (OpReg dst)) + in + returnSUs (Any PtrKind code) + where + imm = maybeImm leaf + imm__2 = case imm of Just x -> x + +\end{code} + +Now, given a tree (the argument to an StInd) that references memory, +produce a suitable addressing mode. + +\begin{code} + +getAmode :: StixTree -> SUniqSM Amode + +getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree) + +getAmode (StPrim IntSubOp [x, StInt i]) + = + getNewRegNCG PtrKind `thenSUs` \ tmp -> + getReg x `thenSUs` \ register -> + let + code = registerCode register tmp + reg = registerName register tmp + off = ImmInt (-(fromInteger i)) + in + returnSUs (Amode (Addr (Just reg) Nothing off) code) + +getAmode (StPrim IntAddOp [x, StInt i]) + | maybeToBool imm + = let + code = mkSeqInstrs [] + in + returnSUs (Amode (ImmAddr imm__2 (fromInteger i)) code) + where + imm = maybeImm x + imm__2 = case imm of Just x -> x + +getAmode (StPrim IntAddOp [x, StInt i]) + = + getNewRegNCG PtrKind `thenSUs` \ tmp -> + getReg x `thenSUs` \ register -> + let + code = registerCode register tmp + reg = registerName register tmp + off = ImmInt (fromInteger i) + in + returnSUs (Amode (Addr (Just reg) Nothing off) code) + +getAmode (StPrim IntAddOp [x, y]) = + getNewRegNCG PtrKind `thenSUs` \ tmp1 -> + getNewRegNCG IntKind `thenSUs` \ tmp2 -> + getReg x `thenSUs` \ register1 -> + getReg y `thenSUs` \ register2 -> + let + code1 = registerCode register1 tmp1 asmVoid + reg1 = registerName register1 tmp1 + code2 = registerCode register2 tmp2 asmVoid + reg2 = registerName register2 tmp2 + code__2 = asmParThen [code1, code2] + in + returnSUs (Amode (Addr (Just reg1) (Just (reg2,4)) (ImmInt 0)) code__2) + +getAmode leaf + | maybeToBool imm = + let code = mkSeqInstrs [] + in + returnSUs (Amode (ImmAddr imm__2 0) code) + where + imm = maybeImm leaf + imm__2 = case imm of Just x -> x + +getAmode other = + getNewRegNCG PtrKind `thenSUs` \ tmp -> + getReg other `thenSUs` \ register -> + let + code = registerCode register tmp + reg = registerName register tmp + off = Nothing + in + returnSUs (Amode (Addr (Just reg) Nothing (ImmInt 0)) code) + +\end{code} + +\begin{code} +getOp + :: StixTree + -> SUniqSM (CodeBlock I386Instr,Operand, Size) -- code, operator, size +getOp (StInt i) + = returnSUs (asmParThen [], OpImm (ImmInt (fromInteger i)), L) + +getOp (StInd pk mem) + = getAmode mem `thenSUs` \ amode -> + let + code = amodeCode amode --asmVoid + addr = amodeAddr amode + sz = kindToSize pk + in returnSUs (code, OpAddr addr, sz) + +getOp op + = getReg op `thenSUs` \ register -> + getNewRegNCG (registerKind register) + `thenSUs` \ tmp -> + let + code = registerCode register tmp + reg = registerName register tmp + pk = registerKind register + sz = kindToSize pk + in + returnSUs (code, OpReg reg, sz) + +getOpRI + :: StixTree + -> SUniqSM (CodeBlock I386Instr,Operand, Size) -- code, operator, size +getOpRI op + | maybeToBool imm + = returnSUs (asmParThen [], OpImm imm_op, L) + where + imm = maybeImm op + imm_op = case imm of Just x -> x + +getOpRI op + = getReg op `thenSUs` \ register -> + getNewRegNCG (registerKind register) + `thenSUs` \ tmp -> + let + code = registerCode register tmp + reg = registerName register tmp + pk = registerKind register + sz = kindToSize pk + in + returnSUs (code, OpReg reg, sz) + +\end{code} + +Set up a condition code for a conditional branch. + +\begin{code} + +getCondition :: StixTree -> SUniqSM Condition + +getCondition (StPrim primop args) = + case primop of + + CharGtOp -> condIntCode GT args + CharGeOp -> condIntCode GE args + CharEqOp -> condIntCode EQ args + CharNeOp -> condIntCode NE args + CharLtOp -> condIntCode LT args + CharLeOp -> condIntCode LE args + + IntGtOp -> condIntCode GT args + IntGeOp -> condIntCode GE args + IntEqOp -> condIntCode EQ args + IntNeOp -> condIntCode NE args + IntLtOp -> condIntCode LT args + IntLeOp -> condIntCode LE args + + WordGtOp -> condIntCode GU args + WordGeOp -> condIntCode GEU args + WordEqOp -> condIntCode EQ args + WordNeOp -> condIntCode NE args + WordLtOp -> condIntCode LU args + WordLeOp -> condIntCode LEU args + + AddrGtOp -> condIntCode GU args + AddrGeOp -> condIntCode GEU args + AddrEqOp -> condIntCode EQ args + AddrNeOp -> condIntCode NE args + AddrLtOp -> condIntCode LU args + AddrLeOp -> condIntCode LEU args + + FloatGtOp -> condFltCode GT args + FloatGeOp -> condFltCode GE args + FloatEqOp -> condFltCode EQ args + FloatNeOp -> condFltCode NE args + FloatLtOp -> condFltCode LT args + FloatLeOp -> condFltCode LE args + + DoubleGtOp -> condFltCode GT args + DoubleGeOp -> condFltCode GE args + DoubleEqOp -> condFltCode EQ args + DoubleNeOp -> condFltCode NE args + DoubleLtOp -> condFltCode LT args + DoubleLeOp -> condFltCode LE args + +\end{code} + +Turn a boolean expression into a condition, to be passed +back up the tree. + +\begin{code} + +condIntCode, condFltCode :: Cond -> [StixTree] -> SUniqSM Condition +condIntCode cond [StInd _ x, y] + | maybeToBool imm + = getAmode x `thenSUs` \ amode -> + let + code1 = amodeCode amode asmVoid + y__2 = amodeAddr amode + code__2 = asmParThen [code1] . + mkSeqInstr (CMP L (OpImm imm__2) (OpAddr y__2)) + in + returnSUs (Condition False cond code__2) + where + imm = maybeImm y + imm__2 = case imm of Just x -> x + +condIntCode cond [x, StInt 0] + = getReg x `thenSUs` \ register1 -> + getNewRegNCG IntKind `thenSUs` \ tmp1 -> + let + code1 = registerCode register1 tmp1 asmVoid + src1 = registerName register1 tmp1 + code__2 = asmParThen [code1] . + mkSeqInstr (TEST L (OpReg src1) (OpReg src1)) + in + returnSUs (Condition False cond code__2) + +condIntCode cond [x, y] + | maybeToBool imm + = getReg x `thenSUs` \ register1 -> + getNewRegNCG IntKind `thenSUs` \ tmp1 -> + let + code1 = registerCode register1 tmp1 asmVoid + src1 = registerName register1 tmp1 + code__2 = asmParThen [code1] . + mkSeqInstr (CMP L (OpImm imm__2) (OpReg src1)) + in + returnSUs (Condition False cond code__2) + where + imm = maybeImm y + imm__2 = case imm of Just x -> x + +condIntCode cond [StInd _ x, y] + = getAmode x `thenSUs` \ amode -> + getReg y `thenSUs` \ register2 -> + getNewRegNCG IntKind `thenSUs` \ tmp2 -> + let + code1 = amodeCode amode asmVoid + src1 = amodeAddr amode + code2 = registerCode register2 tmp2 asmVoid + src2 = registerName register2 tmp2 + code__2 = asmParThen [code1, code2] . + mkSeqInstr (CMP L (OpReg src2) (OpAddr src1)) + in + returnSUs (Condition False cond code__2) + +condIntCode cond [y, StInd _ x] + = getAmode x `thenSUs` \ amode -> + getReg y `thenSUs` \ register2 -> + getNewRegNCG IntKind `thenSUs` \ tmp2 -> + let + code1 = amodeCode amode asmVoid + src1 = amodeAddr amode + code2 = registerCode register2 tmp2 asmVoid + src2 = registerName register2 tmp2 + code__2 = asmParThen [code1, code2] . + mkSeqInstr (CMP L (OpAddr src1) (OpReg src2)) + in + returnSUs (Condition False cond code__2) + +condIntCode cond [x, y] = + getReg x `thenSUs` \ register1 -> + getReg y `thenSUs` \ register2 -> + getNewRegNCG IntKind `thenSUs` \ tmp1 -> + getNewRegNCG IntKind `thenSUs` \ tmp2 -> + let + code1 = registerCode register1 tmp1 asmVoid + src1 = registerName register1 tmp1 + code2 = registerCode register2 tmp2 asmVoid + src2 = registerName register2 tmp2 + code__2 = asmParThen [code1, code2] . + mkSeqInstr (CMP L (OpReg src2) (OpReg src1)) + in + returnSUs (Condition False cond code__2) + +condFltCode cond [x, StDouble 0.0] = + getReg x `thenSUs` \ register1 -> + getNewRegNCG (registerKind register1) + `thenSUs` \ tmp1 -> + let + pk1 = registerKind register1 + code1 = registerCode register1 tmp1 + src1 = registerName register1 tmp1 + + code__2 = asmParThen [code1 asmVoid] . + mkSeqInstrs [FTST, FSTP D (OpReg st0), -- or FLDZ, FUCOMPP ? + FNSTSW, + --AND HB (OpImm (ImmInt 68)) (OpReg eax), + --XOR HB (OpImm (ImmInt 64)) (OpReg eax) + SAHF + ] + in + returnSUs (Condition True (fixFPCond cond) code__2) + +condFltCode cond [x, y] = + getReg x `thenSUs` \ register1 -> + getReg y `thenSUs` \ register2 -> + getNewRegNCG (registerKind register1) + `thenSUs` \ tmp1 -> + getNewRegNCG (registerKind register2) + `thenSUs` \ tmp2 -> + let + pk1 = registerKind register1 + code1 = registerCode register1 tmp1 + src1 = registerName register1 tmp1 + + code2 = registerCode register2 tmp2 + src2 = registerName register2 tmp2 + + code__2 = asmParThen [code2 asmVoid, code1 asmVoid] . + mkSeqInstrs [FUCOMPP, + FNSTSW, + --AND HB (OpImm (ImmInt 68)) (OpReg eax), + --XOR HB (OpImm (ImmInt 64)) (OpReg eax) + SAHF + ] + in + returnSUs (Condition True (fixFPCond cond) code__2) + +\end{code} + +Turn those condition codes into integers now (when they appear on +the right hand side of an assignment). + +\begin{code} + +condIntReg :: Cond -> [StixTree] -> SUniqSM Register +condIntReg cond args = + condIntCode cond args `thenSUs` \ condition -> + getNewRegNCG IntKind `thenSUs` \ tmp -> + --getReg dst `thenSUs` \ register -> + let + --code2 = registerCode register tmp asmVoid + --dst__2 = registerName register tmp + code = condCode condition + cond = condName condition +-- ToDo: if dst is eax, ebx, ecx, or edx we would not need the move. + code__2 dst = code . mkSeqInstrs [ + SETCC cond (OpReg tmp), + AND L (OpImm (ImmInt 1)) (OpReg tmp), + MOV L (OpReg tmp) (OpReg dst)] + in + returnSUs (Any IntKind code__2) + +condFltReg :: Cond -> [StixTree] -> SUniqSM Register + +condFltReg cond args = + getUniqLabelNCG `thenSUs` \ lbl1 -> + getUniqLabelNCG `thenSUs` \ lbl2 -> + condFltCode cond args `thenSUs` \ condition -> + let + code = condCode condition + cond = condName condition + code__2 dst = code . mkSeqInstrs [ + JXX cond lbl1, + MOV L (OpImm (ImmInt 0)) (OpReg dst), + JXX ALWAYS lbl2, + LABEL lbl1, + MOV L (OpImm (ImmInt 1)) (OpReg dst), + LABEL lbl2] + in + returnSUs (Any IntKind code__2) + +\end{code} + +Assignments are really at the heart of the whole code generation business. +Almost all top-level nodes of any real importance are assignments, which +correspond to loads, stores, or register transfers. If we're really lucky, +some of the register transfers will go away, because we can use the destination +register to complete the code generation for the right hand side. This only +fails when the right hand side is forced into a fixed register (e.g. the result +of a call). + +\begin{code} + +assignIntCode :: PrimKind -> StixTree -> StixTree -> SUniqSM (CodeBlock I386Instr) +assignIntCode pk (StInd _ dst) src + = getAmode dst `thenSUs` \ amode -> + getOpRI src `thenSUs` \ (codesrc, opsrc, sz) -> + let + code1 = amodeCode amode asmVoid + dst__2 = amodeAddr amode + code__2 = asmParThen [code1, codesrc asmVoid] . + mkSeqInstr (MOV sz opsrc (OpAddr dst__2)) + in + returnSUs code__2 + +assignIntCode pk dst (StInd _ src) = + getNewRegNCG IntKind `thenSUs` \ tmp -> + getAmode src `thenSUs` \ amode -> + getReg dst `thenSUs` \ register -> + let + code1 = amodeCode amode asmVoid + src__2 = amodeAddr amode + code2 = registerCode register tmp asmVoid + dst__2 = registerName register tmp + sz = kindToSize pk + code__2 = asmParThen [code1, code2] . + mkSeqInstr (MOV sz (OpAddr src__2) (OpReg dst__2)) + in + returnSUs code__2 + +assignIntCode pk dst src = + getReg dst `thenSUs` \ register1 -> + getReg src `thenSUs` \ register2 -> + getNewRegNCG IntKind `thenSUs` \ tmp -> + let + dst__2 = registerName register1 tmp + code = registerCode register2 dst__2 + src__2 = registerName register2 dst__2 + code__2 = if isFixed register2 && dst__2 /= src__2 + then code . mkSeqInstr (MOV L (OpReg src__2) (OpReg dst__2)) + else + code + in + returnSUs code__2 + +assignFltCode :: PrimKind -> StixTree -> StixTree -> SUniqSM (CodeBlock I386Instr) +assignFltCode pk (StInd pk_dst dst) (StInd pk_src src) + = getNewRegNCG IntKind `thenSUs` \ tmp -> + getAmode src `thenSUs` \ amodesrc -> + getAmode dst `thenSUs` \ amodedst -> + --getReg src `thenSUs` \ register -> + let + codesrc1 = amodeCode amodesrc asmVoid + addrsrc1 = amodeAddr amodesrc + codedst1 = amodeCode amodedst asmVoid + addrdst1 = amodeAddr amodedst + addrsrc2 = case (offset addrsrc1 4) of Just x -> x + addrdst2 = case (offset addrdst1 4) of Just x -> x + + code__2 = asmParThen [codesrc1, codedst1] . + mkSeqInstrs ([MOV L (OpAddr addrsrc1) (OpReg tmp), + MOV L (OpReg tmp) (OpAddr addrdst1)] + ++ + if pk == DoubleKind + then [MOV L (OpAddr addrsrc2) (OpReg tmp), + MOV L (OpReg tmp) (OpAddr addrdst2)] + else []) + in + returnSUs code__2 + +assignFltCode pk (StInd _ dst) src = + --getNewRegNCG pk `thenSUs` \ tmp -> + getAmode dst `thenSUs` \ amode -> + getReg src `thenSUs` \ register -> + let + sz = kindToSize pk + dst__2 = amodeAddr amode + + code1 = amodeCode amode asmVoid + code2 = registerCode register {-tmp-}st0 asmVoid + + --src__2 = registerName register tmp + pk__2 = registerKind register + sz__2 = kindToSize pk__2 + + code__2 = asmParThen [code1, code2] . + mkSeqInstr (FSTP sz (OpAddr dst__2)) + in + returnSUs code__2 + +assignFltCode pk dst src = + getReg dst `thenSUs` \ register1 -> + getReg src `thenSUs` \ register2 -> + --getNewRegNCG (registerKind register2) + -- `thenSUs` \ tmp -> + let + sz = kindToSize pk + dst__2 = registerName register1 st0 --tmp + + code = registerCode register2 dst__2 + src__2 = registerName register2 dst__2 + + code__2 = code + in + returnSUs code__2 + +\end{code} + +Generating an unconditional branch. We accept two types of targets: +an immediate CLabel or a tree that gets evaluated into a register. +Any CLabels which are AsmTemporaries are assumed to be in the local +block of code, close enough for a branch instruction. Other CLabels +are assumed to be far away, so we use call. + +Do not fill the delay slots here; you will confuse the register allocator. + +\begin{code} + +genJump + :: StixTree -- the branch target + -> SUniqSM (CodeBlock I386Instr) + +{- +genJump (StCLbl lbl) + | isAsmTemp lbl = returnInstrs [JXX ALWAYS lbl] + | otherwise = returnInstrs [JMP (OpImm target)] + where + target = ImmCLbl lbl +-} + +genJump (StInd pk mem) = + getAmode mem `thenSUs` \ amode -> + let + code = amodeCode amode + target = amodeAddr amode + in + returnSeq code [JMP (OpAddr target)] + +genJump tree + | maybeToBool imm + = returnInstr (JMP (OpImm target)) + where + imm = maybeImm tree + target = case imm of Just x -> x + + +genJump tree = + getReg tree `thenSUs` \ register -> + getNewRegNCG PtrKind `thenSUs` \ tmp -> + let + code = registerCode register tmp + target = registerName register tmp + in + returnSeq code [JMP (OpReg target)] + +\end{code} + +Conditional jumps are always to local labels, so we can use +branch instructions. First, we have to ensure that the condition +codes are set according to the supplied comparison operation. + +\begin{code} + +genCondJump + :: CLabel -- the branch target + -> StixTree -- the condition on which to branch + -> SUniqSM (CodeBlock I386Instr) + +genCondJump lbl bool = + getCondition bool `thenSUs` \ condition -> + let + code = condCode condition + cond = condName condition + target = ImmCLbl lbl + in + returnSeq code [JXX cond lbl] + +\end{code} + +\begin{code} + +genCCall + :: FAST_STRING -- function to call + -> PrimKind -- type of the result + -> [StixTree] -- arguments (of mixed type) + -> SUniqSM (CodeBlock I386Instr) + +genCCall fn kind [StInt i] + | fn == SLIT ("PerformGC_wrapper") + = getUniqLabelNCG `thenSUs` \ lbl -> + let + call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax), + MOV L (OpImm (ImmCLbl lbl)) + -- this is hardwired + (OpAddr (Addr (Just ebx) Nothing (ImmInt 104))), + JMP (OpImm (ImmLit (uppPStr (SLIT ("_PerformGC_wrapper"))))), + LABEL lbl] + in + returnInstrs call + +genCCall fn kind args = + mapSUs getCallArg args `thenSUs` \ argCode -> + let + nargs = length args + code1 = asmParThen [asmSeq [ -- MOV L (OpReg esp) (OpAddr (Addr (Just ebx) Nothing (ImmInt 80))), + MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt 100))) (OpReg esp) + ] + ] + code2 = asmParThen (map ($ asmVoid) (reverse argCode)) + call = [CALL (ImmLit fn__2) -- , + -- ADD L (OpImm (ImmInt (nargs * 4))) (OpReg esp), + -- MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt 80))) (OpReg esp) + ] + in + returnSeq (code1 . code2) call + where + -- function names that begin with '.' are assumed to be special internally + -- generated names like '.mul,' which don't get an underscore prefix + fn__2 = case (_HEAD_ fn) of + '.' -> uppPStr fn + _ -> uppBeside (uppChar '_') (uppPStr fn) + + getCallArg + :: StixTree -- Current argument + -> SUniqSM (CodeBlock I386Instr) -- code + getCallArg arg = + getOp arg `thenSUs` \ (code, op, sz) -> + returnSUs (code . mkSeqInstr (PUSH sz op)) +\end{code} + +Trivial (dyadic) instructions. Only look for constants on the right hand +side, because that's where the generic optimizer will have put them. + +\begin{code} + +trivialCode + :: (Operand -> Operand -> I386Instr) + -> [StixTree] + -> Bool -- is the instr commutative? + -> SUniqSM Register + +trivialCode instr [x, y] _ + | maybeToBool imm + = getReg x `thenSUs` \ register1 -> + --getNewRegNCG IntKind `thenSUs` \ tmp1 -> + let + fixedname = registerName register1 eax + code__2 dst = let code1 = registerCode register1 dst + src1 = registerName register1 dst + in code1 . + if isFixed register1 && src1 /= dst + then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst), + instr (OpImm imm__2) (OpReg dst)] + else + mkSeqInstrs [instr (OpImm imm__2) (OpReg src1)] + in + returnSUs (Any IntKind code__2) + where + imm = maybeImm y + imm__2 = case imm of Just x -> x + +trivialCode instr [x, y] _ + | maybeToBool imm + = getReg y `thenSUs` \ register1 -> + --getNewRegNCG IntKind `thenSUs` \ tmp1 -> + let + fixedname = registerName register1 eax + code__2 dst = let code1 = registerCode register1 dst + src1 = registerName register1 dst + in code1 . + if isFixed register1 && src1 /= dst + then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst), + instr (OpImm imm__2) (OpReg dst)] + else + mkSeqInstr (instr (OpImm imm__2) (OpReg src1)) + in + returnSUs (Any IntKind code__2) + where + imm = maybeImm x + imm__2 = case imm of Just x -> x + +trivialCode instr [x, StInd pk mem] _ + = getReg x `thenSUs` \ register -> + --getNewRegNCG IntKind `thenSUs` \ tmp -> + getAmode mem `thenSUs` \ amode -> + let + fixedname = registerName register eax + code2 = amodeCode amode asmVoid + src2 = amodeAddr amode + code__2 dst = let code1 = registerCode register dst asmVoid + src1 = registerName register dst + in asmParThen [code1, code2] . + if isFixed register && src1 /= dst + then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst), + instr (OpAddr src2) (OpReg dst)] + else + mkSeqInstr (instr (OpAddr src2) (OpReg src1)) + in + returnSUs (Any pk code__2) + +trivialCode instr [StInd pk mem, y] _ + = getReg y `thenSUs` \ register -> + --getNewRegNCG IntKind `thenSUs` \ tmp -> + getAmode mem `thenSUs` \ amode -> + let + fixedname = registerName register eax + code2 = amodeCode amode asmVoid + src2 = amodeAddr amode + code__2 dst = let + code1 = registerCode register dst asmVoid + src1 = registerName register dst + in asmParThen [code1, code2] . + if isFixed register && src1 /= dst + then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst), + instr (OpAddr src2) (OpReg dst)] + else + mkSeqInstr (instr (OpAddr src2) (OpReg src1)) + in + returnSUs (Any pk code__2) + +trivialCode instr [x, y] is_comm_op + = getReg x `thenSUs` \ register1 -> + getReg y `thenSUs` \ register2 -> + --getNewRegNCG IntKind `thenSUs` \ tmp1 -> + getNewRegNCG IntKind `thenSUs` \ tmp2 -> + let + fixedname = registerName register1 eax + code2 = registerCode register2 tmp2 asmVoid + src2 = registerName register2 tmp2 + code__2 dst = let + code1 = registerCode register1 dst asmVoid + src1 = registerName register1 dst + in asmParThen [code1, code2] . + if isFixed register1 && src1 /= dst + then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst), + instr (OpReg src2) (OpReg dst)] + else + mkSeqInstr (instr (OpReg src2) (OpReg src1)) + in + returnSUs (Any IntKind code__2) + +addCode + :: Size + -> [StixTree] + -> SUniqSM Register +addCode sz [x, StInt y] + = + getReg x `thenSUs` \ register -> + getNewRegNCG IntKind `thenSUs` \ tmp -> + let + code = registerCode register tmp + src1 = registerName register tmp + src2 = ImmInt (fromInteger y) + code__2 dst = code . + mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) Nothing src2)) (OpReg dst)) + in + returnSUs (Any IntKind code__2) + +addCode sz [x, StInd _ mem] + = getReg x `thenSUs` \ register1 -> + --getNewRegNCG (registerKind register1) + -- `thenSUs` \ tmp1 -> + getAmode mem `thenSUs` \ amode -> + let + code2 = amodeCode amode + src2 = amodeAddr amode + + fixedname = registerName register1 eax + code__2 dst = let code1 = registerCode register1 dst + src1 = registerName register1 dst + in asmParThen [code2 asmVoid,code1 asmVoid] . + if isFixed register1 && src1 /= dst + then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst), + ADD sz (OpAddr src2) (OpReg dst)] + else + mkSeqInstrs [ADD sz (OpAddr src2) (OpReg src1)] + in + returnSUs (Any IntKind code__2) + +addCode sz [StInd _ mem, y] + = getReg y `thenSUs` \ register2 -> + --getNewRegNCG (registerKind register2) + -- `thenSUs` \ tmp2 -> + getAmode mem `thenSUs` \ amode -> + let + code1 = amodeCode amode + src1 = amodeAddr amode + + fixedname = registerName register2 eax + code__2 dst = let code2 = registerCode register2 dst + src2 = registerName register2 dst + in asmParThen [code1 asmVoid,code2 asmVoid] . + if isFixed register2 && src2 /= dst + then mkSeqInstrs [MOV L (OpReg src2) (OpReg dst), + ADD sz (OpAddr src1) (OpReg dst)] + else + mkSeqInstrs [ADD sz (OpAddr src1) (OpReg src2)] + in + returnSUs (Any IntKind code__2) + +addCode sz [x, y] = + getReg x `thenSUs` \ register1 -> + getReg y `thenSUs` \ register2 -> + getNewRegNCG IntKind `thenSUs` \ tmp1 -> + getNewRegNCG IntKind `thenSUs` \ tmp2 -> + let + code1 = registerCode register1 tmp1 asmVoid + src1 = registerName register1 tmp1 + code2 = registerCode register2 tmp2 asmVoid + src2 = registerName register2 tmp2 + code__2 dst = asmParThen [code1, code2] . + mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) (Just (src2,1)) (ImmInt 0))) (OpReg dst)) + in + returnSUs (Any IntKind code__2) + +subCode + :: Size + -> [StixTree] + -> SUniqSM Register +subCode sz [x, StInt y] + = getReg x `thenSUs` \ register -> + getNewRegNCG IntKind `thenSUs` \ tmp -> + let + code = registerCode register tmp + src1 = registerName register tmp + src2 = ImmInt (-(fromInteger y)) + code__2 dst = code . + mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) Nothing src2)) (OpReg dst)) + in + returnSUs (Any IntKind code__2) + +subCode sz args = trivialCode (SUB sz) args False + +divCode + :: Size + -> [StixTree] + -> Bool -- True => division, False => remainder operation + -> SUniqSM Register + +-- x must go into eax, edx must be a sign-extension of eax, +-- and y should go in some other register (or memory), +-- so that we get edx:eax / reg -> eax (remainder in edx) +-- Currently we chose to put y in memory (if it is not there already) +divCode sz [x, StInd pk mem] is_division + = getReg x `thenSUs` \ register1 -> + getNewRegNCG IntKind `thenSUs` \ tmp1 -> + getAmode mem `thenSUs` \ amode -> + let + code1 = registerCode register1 tmp1 asmVoid + src1 = registerName register1 tmp1 + code2 = amodeCode amode asmVoid + src2 = amodeAddr amode + code__2 = asmParThen [code1, code2] . + mkSeqInstrs [MOV L (OpReg src1) (OpReg eax), + CLTD, + IDIV sz (OpAddr src2)] + in + returnSUs (Fixed (if is_division then eax else edx) IntKind code__2) + +divCode sz [x, StInt i] is_division + = getReg x `thenSUs` \ register1 -> + getNewRegNCG IntKind `thenSUs` \ tmp1 -> + let + code1 = registerCode register1 tmp1 asmVoid + src1 = registerName register1 tmp1 + src2 = ImmInt (fromInteger i) + code__2 = asmParThen [code1] . + mkSeqInstrs [-- we put src2 in (ebx) + MOV L (OpImm src2) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))), + MOV L (OpReg src1) (OpReg eax), + CLTD, + IDIV sz (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)))] + in + returnSUs (Fixed (if is_division then eax else edx) IntKind code__2) + +divCode sz [x, y] is_division + = getReg x `thenSUs` \ register1 -> + getNewRegNCG IntKind `thenSUs` \ tmp1 -> + getReg y `thenSUs` \ register2 -> + getNewRegNCG IntKind `thenSUs` \ tmp2 -> + let + code1 = registerCode register1 tmp1 asmVoid + src1 = registerName register1 tmp1 + code2 = registerCode register2 tmp2 asmVoid + src2 = registerName register2 tmp2 + code__2 = asmParThen [code1, code2] . + if src2 == ecx || src2 == esi + then mkSeqInstrs [ MOV L (OpReg src1) (OpReg eax), + CLTD, + IDIV sz (OpReg src2)] + else mkSeqInstrs [ -- we put src2 in (ebx) + MOV L (OpReg src2) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))), + MOV L (OpReg src1) (OpReg eax), + CLTD, + IDIV sz (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)))] + in + returnSUs (Fixed (if is_division then eax else edx) IntKind code__2) + +trivialFCode + :: PrimKind + -> (Size -> Operand -> I386Instr) + -> (Size -> Operand -> I386Instr) -- reversed instr + -> I386Instr -- pop + -> I386Instr -- reversed instr, pop + -> [StixTree] + -> SUniqSM Register +trivialFCode pk _ instrr _ _ [StInd pk' mem, y] + = getReg y `thenSUs` \ register2 -> + --getNewRegNCG (registerKind register2) + -- `thenSUs` \ tmp2 -> + getAmode mem `thenSUs` \ amode -> + let + code1 = amodeCode amode + src1 = amodeAddr amode + + code__2 dst = let + code2 = registerCode register2 dst + src2 = registerName register2 dst + in asmParThen [code1 asmVoid,code2 asmVoid] . + mkSeqInstrs [instrr (kindToSize pk) (OpAddr src1)] + in + returnSUs (Any pk code__2) + +trivialFCode pk instr _ _ _ [x, StInd pk' mem] + = getReg x `thenSUs` \ register1 -> + --getNewRegNCG (registerKind register1) + -- `thenSUs` \ tmp1 -> + getAmode mem `thenSUs` \ amode -> + let + code2 = amodeCode amode + src2 = amodeAddr amode + + code__2 dst = let + code1 = registerCode register1 dst + src1 = registerName register1 dst + in asmParThen [code2 asmVoid,code1 asmVoid] . + mkSeqInstrs [instr (kindToSize pk) (OpAddr src2)] + in + returnSUs (Any pk code__2) + +trivialFCode pk _ _ _ instrpr [x, y] = + getReg x `thenSUs` \ register1 -> + getReg y `thenSUs` \ register2 -> + --getNewRegNCG (registerKind register1) + -- `thenSUs` \ tmp1 -> + --getNewRegNCG (registerKind register2) + -- `thenSUs` \ tmp2 -> + getNewRegNCG DoubleKind `thenSUs` \ tmp -> + let + pk1 = registerKind register1 + code1 = registerCode register1 st0 --tmp1 + src1 = registerName register1 st0 --tmp1 + + pk2 = registerKind register2 + + code__2 dst = let + code2 = registerCode register2 dst + src2 = registerName register2 dst + in asmParThen [code1 asmVoid, code2 asmVoid] . + mkSeqInstr instrpr + in + returnSUs (Any pk1 code__2) + +\end{code} + +Trivial unary instructions. Note that we don't have to worry about +matching an StInt as the argument, because genericOpt will already +have handled the constant-folding. + +\begin{code} + +trivialUCode + :: (Operand -> I386Instr) + -> [StixTree] + -> SUniqSM Register + +trivialUCode instr [x] = + getReg x `thenSUs` \ register -> +-- getNewRegNCG IntKind `thenSUs` \ tmp -> + let +-- fixedname = registerName register eax + code__2 dst = let + code = registerCode register dst + src = registerName register dst + in code . if isFixed register && dst /= src + then mkSeqInstrs [MOV L (OpReg src) (OpReg dst), + instr (OpReg dst)] + else mkSeqInstr (instr (OpReg src)) + in + returnSUs (Any IntKind code__2) + +trivialUFCode + :: PrimKind + -> I386Instr + -> [StixTree] + -> SUniqSM Register + +trivialUFCode pk instr [StInd pk' mem] = + getAmode mem `thenSUs` \ amode -> + let + code = amodeCode amode + src = amodeAddr amode + code__2 dst = code . mkSeqInstrs [FLD (kindToSize pk) (OpAddr src), + instr] + in + returnSUs (Any pk code__2) + +trivialUFCode pk instr [x] = + getReg x `thenSUs` \ register -> + --getNewRegNCG pk `thenSUs` \ tmp -> + let + code__2 dst = let + code = registerCode register dst + src = registerName register dst + in code . mkSeqInstrs [instr] + in + returnSUs (Any pk code__2) +\end{code} + +Absolute value on integers, mostly for gmp size check macros. Again, +the argument cannot be an StInt, because genericOpt already folded +constants. + +\begin{code} + +absIntCode :: [StixTree] -> SUniqSM Register +absIntCode [x] = + getReg x `thenSUs` \ register -> + --getNewRegNCG IntKind `thenSUs` \ reg -> + getUniqLabelNCG `thenSUs` \ lbl -> + let + code__2 dst = let code = registerCode register dst + src = registerName register dst + in code . if isFixed register && dst /= src + then mkSeqInstrs [MOV L (OpReg src) (OpReg dst), + TEST L (OpReg dst) (OpReg dst), + JXX GE lbl, + NEGI L (OpReg dst), + LABEL lbl] + else mkSeqInstrs [TEST L (OpReg src) (OpReg src), + JXX GE lbl, + NEGI L (OpReg src), + LABEL lbl] + in + returnSUs (Any IntKind code__2) + +\end{code} + +Simple integer coercions that don't require any code to be generated. +Here we just change the type on the register passed on up + +\begin{code} + +coerceIntCode :: PrimKind -> [StixTree] -> SUniqSM Register +coerceIntCode pk [x] = + getReg x `thenSUs` \ register -> + case register of + Fixed reg _ code -> returnSUs (Fixed reg pk code) + Any _ code -> returnSUs (Any pk code) + +coerceFltCode :: [StixTree] -> SUniqSM Register +coerceFltCode [x] = + getReg x `thenSUs` \ register -> + case register of + Fixed reg _ code -> returnSUs (Fixed reg DoubleKind code) + Any _ code -> returnSUs (Any DoubleKind code) + +\end{code} + +Integer to character conversion. We try to do this in one step if +the original object is in memory. + +\begin{code} +chrCode :: [StixTree] -> SUniqSM Register +{- +chrCode [StInd pk mem] = + getAmode mem `thenSUs` \ amode -> + let + code = amodeCode amode + src = amodeAddr amode + code__2 dst = code . mkSeqInstr (MOVZX L (OpAddr src) (OpReg dst)) + in + returnSUs (Any pk code__2) +-} +chrCode [x] = + getReg x `thenSUs` \ register -> + --getNewRegNCG IntKind `thenSUs` \ reg -> + let + fixedname = registerName register eax + code__2 dst = let + code = registerCode register dst + src = registerName register dst + in code . + if isFixed register && src /= dst + then mkSeqInstrs [MOV L (OpReg src) (OpReg dst), + AND L (OpImm (ImmInt 255)) (OpReg dst)] + else mkSeqInstr (AND L (OpImm (ImmInt 255)) (OpReg src)) + in + returnSUs (Any IntKind code__2) + +\end{code} + +More complicated integer/float conversions. Here we have to store +temporaries in memory to move between the integer and the floating +point register sets. + +\begin{code} +coerceInt2FP :: PrimKind -> [StixTree] -> SUniqSM Register +coerceInt2FP pk [x] = + getReg x `thenSUs` \ register -> + getNewRegNCG IntKind `thenSUs` \ reg -> + let + code = registerCode register reg + src = registerName register reg + + code__2 dst = code . mkSeqInstrs [ + -- to fix: should spill instead of using R1 + MOV L (OpReg src) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))), + FILD (kindToSize pk) (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)) dst] + in + returnSUs (Any pk code__2) + +coerceFP2Int :: [StixTree] -> SUniqSM Register +coerceFP2Int [x] = + getReg x `thenSUs` \ register -> + getNewRegNCG DoubleKind `thenSUs` \ tmp -> + let + code = registerCode register tmp + src = registerName register tmp + pk = registerKind register + + code__2 dst = let + in code . mkSeqInstrs [ + FRNDINT, + FIST L (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)), + MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))) (OpReg dst)] + in + returnSUs (Any IntKind code__2) +\end{code} + +Some random little helpers. + +\begin{code} + +maybeImm :: StixTree -> Maybe Imm +maybeImm (StInt i) + | i >= toInteger minInt && i <= toInteger maxInt = Just (ImmInt (fromInteger i)) + | otherwise = Just (ImmInteger i) +maybeImm (StLitLbl s) = Just (ImmLit (uppBeside (uppChar '_') s)) +maybeImm (StLitLit s) = Just (strImmLit (cvtLitLit (_UNPK_ s))) +maybeImm (StCLbl l) = Just (ImmCLbl l) +maybeImm _ = Nothing + +mangleIndexTree :: StixTree -> StixTree + +mangleIndexTree (StIndex pk base (StInt i)) = + StPrim IntAddOp [base, off] + where + off = StInt (i * size pk) + size :: PrimKind -> Integer + size pk = case kindToSize pk of + {B -> 1; S -> 2; L -> 4; F -> 4; D -> 8 } + +mangleIndexTree (StIndex pk base off) = + case pk of + CharKind -> StPrim IntAddOp [base, off] + _ -> StPrim IntAddOp [base, off__2] + where + off__2 = StPrim SllOp [off, StInt (shift pk)] + shift :: PrimKind -> Integer + shift DoubleKind = 3 + shift _ = 2 + +cvtLitLit :: String -> String +cvtLitLit "stdin" = "_IO_stdin_" +cvtLitLit "stdout" = "_IO_stdout_" +cvtLitLit "stderr" = "_IO_stderr_" +cvtLitLit s + | isHex s = s + | otherwise = error ("Native code generator can't handle ``" ++ s ++ "''") + where + isHex ('0':'x':xs) = all isHexDigit xs + isHex _ = False + -- Now, where have I seen this before? + isHexDigit c = isDigit c || c >= 'A' && c <= 'F' || c >= 'a' && c <= 'f' + + +\end{code} + +\begin{code} + +stackArgLoc = 23 :: Int -- where to stack call arguments + +\end{code} + +\begin{code} + +getNewRegNCG :: PrimKind -> SUniqSM Reg +getNewRegNCG pk = + getSUnique `thenSUs` \ u -> + returnSUs (mkReg u pk) + +fixFPCond :: Cond -> Cond +-- on the 486 the flags set by FP compare are the unsigned ones! +fixFPCond GE = GEU +fixFPCond GT = GU +fixFPCond LT = LU +fixFPCond LE = LEU +fixFPCond any = any +\end{code} diff --git a/ghc/compiler/nativeGen/MachDesc.hi b/ghc/compiler/nativeGen/MachDesc.hi index 674a64981b..abc8db6c19 100644 --- a/ghc/compiler/nativeGen/MachDesc.hi +++ b/ghc/compiler/nativeGen/MachDesc.hi @@ -14,82 +14,51 @@ import PreludeRatio(Ratio(..)) import Pretty(PprStyle) import PrimKind(PrimKind) import PrimOps(PrimOp) -import SMRep(SMRep, SMSpecRepKind, SMUpdateKind) +import SMRep(SMRep) import SplitUniq(SUniqSM(..), SplitUniqSupply) import Stix(CodeSegment, StixReg, StixTree, StixTreeList(..)) -import UniType(UniType) import Unique(Unique) import Unpretty(Unpretty(..)) -data AbstractC {-# GHC_PRAGMA AbsCNop | AbsCStmts AbstractC AbstractC | CAssign CAddrMode CAddrMode | CJump CAddrMode | CFallThrough CAddrMode | CReturn CAddrMode ReturnInfo | CSwitch CAddrMode [(BasicLit, AbstractC)] AbstractC | CCodeBlock CLabel AbstractC | CInitHdr ClosureInfo RegRelative CAddrMode Bool | COpStmt [CAddrMode] PrimOp [CAddrMode] Int [MagicId] | CSimultaneous AbstractC | CMacroStmt CStmtMacro [CAddrMode] | CCallProfCtrMacro _PackedString [CAddrMode] | CCallProfCCMacro _PackedString [CAddrMode] | CStaticClosure CLabel ClosureInfo CAddrMode [CAddrMode] | CClosureInfoAndCode ClosureInfo AbstractC (Labda AbstractC) CAddrMode [Char] | CRetVector CLabel [Labda CAddrMode] AbstractC | CRetUnVector CLabel CAddrMode | CFlatRetVector CLabel [CAddrMode] | CCostCentreDecl Bool CostCentre | CClosureUpdInfo AbstractC | CSplitMarker #-} -data CAddrMode {-# GHC_PRAGMA CVal RegRelative PrimKind | CAddr RegRelative | CReg MagicId | CTableEntry CAddrMode CAddrMode PrimKind | CTemp Unique PrimKind | CLbl CLabel PrimKind | CUnVecLbl CLabel CLabel | CCharLike CAddrMode | CIntLike CAddrMode | CString _PackedString | CLit BasicLit | CLitLit _PackedString PrimKind | COffset HeapOffset | CCode AbstractC | CLabelledCode CLabel AbstractC | CJoinPoint Int Int | CMacroExpr PrimKind CExprMacro [CAddrMode] | CCostCentre CostCentre Bool #-} -data CExprMacro {-# GHC_PRAGMA INFO_PTR | ENTRY_CODE | INFO_TAG | EVAL_TAG #-} -data CStmtMacro {-# GHC_PRAGMA ARGS_CHK_A_LOAD_NODE | ARGS_CHK_A | ARGS_CHK_B_LOAD_NODE | ARGS_CHK_B | HEAP_CHK | STK_CHK | UPD_CAF | UPD_IND | UPD_INPLACE_NOPTRS | UPD_INPLACE_PTRS | UPD_BH_UPDATABLE | UPD_BH_SINGLE_ENTRY | PUSH_STD_UPD_FRAME | POP_STD_UPD_FRAME | SET_ARITY | CHK_ARITY | SET_TAG #-} -data MagicId {-# GHC_PRAGMA BaseReg | StkOReg | VanillaReg PrimKind Int# | FloatReg Int# | DoubleReg Int# | TagReg | RetReg | SpA | SuA | SpB | SuB | Hp | HpLim | LivenessReg | ActivityReg | StdUpdRetVecReg | StkStubReg | CurCostCentre | VoidReg #-} -data RegRelative {-# GHC_PRAGMA HpRel HeapOffset HeapOffset | SpARel Int Int | SpBRel Int Int | NodeRel HeapOffset #-} -data BasicLit {-# GHC_PRAGMA MachChar Char | MachStr _PackedString | MachAddr Integer | MachInt Integer Bool | MachFloat (Ratio Integer) | MachDouble (Ratio Integer) | MachLitLit _PackedString PrimKind | NoRepStr _PackedString | NoRepInteger Integer | NoRepRational (Ratio Integer) #-} +data AbstractC +data CAddrMode +data CExprMacro +data CStmtMacro +data MagicId +data RegRelative +data BasicLit data CLabel -data CSeq {-# GHC_PRAGMA CNil | CAppend CSeq CSeq | CIndent Int CSeq | CNewline | CStr [Char] | CCh Char | CInt Int | CPStr _PackedString #-} -data GlobalSwitch - {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-} +data CSeq +data GlobalSwitch data RegLoc = Save StixTree | Always StixTree -data SwitchResult {-# GHC_PRAGMA SwBool Bool | SwString [Char] | SwInt Int #-} +data SwitchResult data HeapOffset -data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-} -data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-} -data PrimOp - {-# GHC_PRAGMA 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 | OrdOp | ChrOp | IntAddOp | IntSubOp | IntMulOp | IntQuotOp | IntDivOp | IntRemOp | IntNegOp | IntAbsOp | AndOp | OrOp | NotOp | SllOp | SraOp | SrlOp | ISllOp | ISraOp | ISrlOp | Int2WordOp | Word2IntOp | Int2AddrOp | Addr2IntOp | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp | Float2IntOp | Int2FloatOp | FloatExpOp | FloatLogOp | FloatSqrtOp | FloatSinOp | FloatCosOp | FloatTanOp | FloatAsinOp | FloatAcosOp | FloatAtanOp | FloatSinhOp | FloatCoshOp | FloatTanhOp | FloatPowerOp | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp | Double2IntOp | Int2DoubleOp | Double2FloatOp | Float2DoubleOp | DoubleExpOp | DoubleLogOp | DoubleSqrtOp | DoubleSinOp | DoubleCosOp | DoubleTanOp | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp | DoublePowerOp | IntegerAddOp | IntegerSubOp | IntegerMulOp | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp | IntegerCmpOp | Integer2IntOp | Int2IntegerOp | Word2IntegerOp | Addr2IntegerOp | FloatEncodeOp | FloatDecodeOp | DoubleEncodeOp | DoubleDecodeOp | NewArrayOp | NewByteArrayOp PrimKind | SameMutableArrayOp | SameMutableByteArrayOp | ReadArrayOp | WriteArrayOp | IndexArrayOp | ReadByteArrayOp PrimKind | WriteByteArrayOp PrimKind | IndexByteArrayOp PrimKind | IndexOffAddrOp PrimKind | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp | NewSynchVarOp | TakeMVarOp | PutMVarOp | ReadIVarOp | WriteIVarOp | MakeStablePtrOp | DeRefStablePtrOp | CCallOp _PackedString Bool Bool [UniType] UniType | ErrorIOPrimOp | ReallyUnsafePtrEqualityOp | SeqOp | ParOp | ForkOp | DelayOp | WaitOp #-} -data SMRep {-# GHC_PRAGMA StaticRep Int Int | SpecialisedRep SMSpecRepKind Int Int SMUpdateKind | GenericRep Int Int SMUpdateKind | BigTupleRep Int | DataRep Int | DynamicRep | BlackHoleRep | PhantomRep | MuTupleRep Int #-} +data PprStyle +data PrimKind +data PrimOp +data SMRep type SUniqSM a = SplitUniqSupply -> a -data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-} -data StixTree {-# GHC_PRAGMA StSegment CodeSegment | StInt Integer | StDouble (Ratio Integer) | StString _PackedString | StLitLbl CSeq | StLitLit _PackedString | StCLbl CLabel | StReg StixReg | StIndex PrimKind StixTree StixTree | StInd PrimKind StixTree | StAssign PrimKind StixTree StixTree | StLabel CLabel | StFunBegin CLabel | StFunEnd CLabel | StJump StixTree | StFallThrough CLabel | StCondJump CLabel StixTree | StData PrimKind [StixTree] | StPrim PrimOp [StixTree] | StCall _PackedString PrimKind [StixTree] | StComment _PackedString #-} +data SplitUniqSupply +data StixTree type StixTreeList = [StixTree] -> [StixTree] -data Target {-# GHC_PRAGMA Target (GlobalSwitch -> SwitchResult) Int (SMRep -> Int) (MagicId -> RegLoc) (StixTree -> StixTree) (PrimKind -> Int) ([MagicId] -> [StixTree]) ([MagicId] -> [StixTree]) (HeapOffset -> Int) (CAddrMode -> StixTree) (CAddrMode -> StixTree) Int Int StixTree StixTree ([CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) Bool ([Char] -> [Char]) #-} -data Unique {-# GHC_PRAGMA MkUnique Int# #-} +data Target = Target Int (SMRep -> Int) (MagicId -> RegLoc) (PrimKind -> Int) (HeapOffset -> Int) (CAddrMode -> StixTree) (CAddrMode -> StixTree) ([MagicId] -> [StixTree], [MagicId] -> [StixTree], Int, Int, StixTree, StixTree, [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree], CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree], StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) +data Unique type Unpretty = CSeq amodeToStix :: Target -> CAddrMode -> StixTree - {-# GHC_PRAGMA _A_ 1 _U_ 12 _N_ _S_ "U(AAAAAAAAASAAAAAAAAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: CAddrMode -> StixTree) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> ua; _NO_DEFLT_ } _N_ #-} amodeToStix' :: Target -> CAddrMode -> StixTree - {-# GHC_PRAGMA _A_ 1 _U_ 12 _N_ _S_ "U(AAAAAAAAAASAAAAAAAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: CAddrMode -> StixTree) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> ub; _NO_DEFLT_ } _N_ #-} charLikeClosureSize :: Target -> Int - {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAAAAAAAAAU(P)AAAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ I# [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> uc; _NO_DEFLT_ } _N_ #-} -codeGen :: Target -> PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq - {-# GHC_PRAGMA _A_ 1 _U_ 1222 _N_ _S_ "U(AAAAAAAAAAAAAAAAAASAA)" {_A_ 1 _U_ 1222 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> uj; _NO_DEFLT_ } _N_ #-} dataHS :: Target -> StixTree - {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAAAAAAAAAAAASAAAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: StixTree) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> uf; _NO_DEFLT_ } _N_ #-} fixedHeaderSize :: Target -> Int - {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AU(P)AAAAAAAAAAAAAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ I# [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> u2; _NO_DEFLT_ } _N_ #-} -fmtAsmLbl :: Target -> [Char] -> [Char] - {-# GHC_PRAGMA _A_ 1 _U_ 12 _N_ _S_ "U(AAAAAAAAAAAAAAAAAAAAS)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: [Char] -> [Char]) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> ul; _NO_DEFLT_ } _N_ #-} heapCheck :: Target -> StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree] - {-# GHC_PRAGMA _A_ 1 _U_ 122222 _N_ _S_ "U(AAAAAAAAAAAAAAAAASAAA)" {_A_ 1 _U_ 122222 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> ui; _NO_DEFLT_ } _N_ #-} hpRel :: Target -> HeapOffset -> Int - {-# GHC_PRAGMA _A_ 1 _U_ 12 _N_ _S_ "U(AAAAAAAASAAAAAAAAAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: HeapOffset -> Int) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> u9; _NO_DEFLT_ } _N_ #-} intLikeClosureSize :: Target -> Int - {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAAAAAAAAAAU(P)AAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ I# [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> ud; _NO_DEFLT_ } _N_ #-} macroCode :: Target -> CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree] - {-# GHC_PRAGMA _A_ 1 _U_ 12222 _N_ _S_ "U(AAAAAAAAAAAAAAAASAAAA)" {_A_ 1 _U_ 12222 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> uh; _NO_DEFLT_ } _N_ #-} -mkTarget :: (GlobalSwitch -> SwitchResult) -> Int -> (SMRep -> Int) -> (MagicId -> RegLoc) -> (StixTree -> StixTree) -> (PrimKind -> Int) -> ([MagicId] -> [StixTree]) -> ([MagicId] -> [StixTree]) -> (HeapOffset -> Int) -> (CAddrMode -> StixTree) -> (CAddrMode -> StixTree) -> Int -> Int -> StixTree -> StixTree -> ([CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) -> (CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) -> (StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) -> (PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) -> Bool -> ([Char] -> [Char]) -> Target - {-# GHC_PRAGMA _A_ 21 _U_ 222222222222222222222 _N_ _N_ _F_ _IF_ARGS_ 0 21 XXXXXXXXXXXXXXXXXXXXX 22 \ (u0 :: GlobalSwitch -> SwitchResult) (u1 :: Int) (u2 :: SMRep -> Int) (u3 :: MagicId -> RegLoc) (u4 :: StixTree -> StixTree) (u5 :: PrimKind -> Int) (u6 :: [MagicId] -> [StixTree]) (u7 :: [MagicId] -> [StixTree]) (u8 :: HeapOffset -> Int) (u9 :: CAddrMode -> StixTree) (ua :: CAddrMode -> StixTree) (ub :: Int) (uc :: Int) (ud :: StixTree) (ue :: StixTree) (uf :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ug :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uj :: Bool) (uk :: [Char] -> [Char]) -> _!_ _ORIG_ MachDesc Target [] [u0, u1, u2, u3, u4, u5, u6, u7, u8, u9, ua, ub, uc, ud, ue, uf, ug, uh, ui, uj, uk] _N_ #-} +mkTarget :: Int -> (SMRep -> Int) -> (MagicId -> RegLoc) -> (PrimKind -> Int) -> (HeapOffset -> Int) -> (CAddrMode -> StixTree) -> (CAddrMode -> StixTree) -> ([MagicId] -> [StixTree], [MagicId] -> [StixTree], Int, Int, StixTree, StixTree, [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree], CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree], StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) -> Target mutHS :: Target -> StixTree - {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAAAAAAAAAAASAAAAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: StixTree) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> ue; _NO_DEFLT_ } _N_ #-} -nativeOpt :: Target -> StixTree -> StixTree - {-# GHC_PRAGMA _A_ 1 _U_ 12 _N_ _S_ "U(AAAASAAAAAAAAAAAAAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: StixTree -> StixTree) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> u5; _NO_DEFLT_ } _N_ #-} primToStix :: Target -> [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree] - {-# GHC_PRAGMA _A_ 1 _U_ 122222 _N_ _S_ "U(AAAAAAAAAAAAAAASAAAAA)" {_A_ 1 _U_ 122222 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> ug; _NO_DEFLT_ } _N_ #-} saveLoc :: Target -> MagicId -> StixTree - {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(AAASAAAAAAAAAAAAAAAAA)L" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-} sizeof :: Target -> PrimKind -> Int - {-# GHC_PRAGMA _A_ 1 _U_ 12 _N_ _S_ "U(AAAAASAAAAAAAAAAAAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: PrimKind -> Int) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> u6; _NO_DEFLT_ } _N_ #-} stgReg :: Target -> MagicId -> RegLoc - {-# GHC_PRAGMA _A_ 1 _U_ 12 _N_ _S_ "U(AAASAAAAAAAAAAAAAAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: MagicId -> RegLoc) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> u4; _NO_DEFLT_ } _N_ #-} -targetSwitches :: Target -> GlobalSwitch -> SwitchResult - {-# GHC_PRAGMA _A_ 1 _U_ 12 _N_ _S_ "U(SAAAAAAAAAAAAAAAAAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: GlobalSwitch -> SwitchResult) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> u1; _NO_DEFLT_ } _N_ #-} -underscore :: Target -> Bool - {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAAAAAAAAAAAAAAAAAEA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: Bool) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> uk; _NO_DEFLT_ } _N_ #-} varHeaderSize :: Target -> SMRep -> Int - {-# GHC_PRAGMA _A_ 1 _U_ 12 _N_ _S_ "U(AASAAAAAAAAAAAAAAAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: SMRep -> Int) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> u3; _NO_DEFLT_ } _N_ #-} volatileRestores :: Target -> [MagicId] -> [StixTree] - {-# GHC_PRAGMA _A_ 1 _U_ 12 _N_ _S_ "U(AAAAAAASAAAAAAAAAAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: [MagicId] -> [StixTree]) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> u8; _NO_DEFLT_ } _N_ #-} volatileSaves :: Target -> [MagicId] -> [StixTree] - {-# GHC_PRAGMA _A_ 1 _U_ 12 _N_ _S_ "U(AAAAAASAAAAAAAAAAAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: [MagicId] -> [StixTree]) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> u7; _NO_DEFLT_ } _N_ #-} diff --git a/ghc/compiler/nativeGen/MachDesc.lhs b/ghc/compiler/nativeGen/MachDesc.lhs index 79b1965674..19b0bcb18d 100644 --- a/ghc/compiler/nativeGen/MachDesc.lhs +++ b/ghc/compiler/nativeGen/MachDesc.lhs @@ -10,15 +10,18 @@ No doubt there will be more... #include "HsVersions.h" module MachDesc ( - Target, mkTarget, RegLoc(..), + Target(..){-(..) for target_STRICT only-}, mkTarget, RegLoc(..), saveLoc, - targetSwitches, fixedHeaderSize, varHeaderSize, stgReg, - nativeOpt, sizeof, volatileSaves, volatileRestores, hpRel, +-- targetSwitches, UNUSED FOR NOW + fixedHeaderSize, varHeaderSize, stgReg, +-- nativeOpt, UNUSED FOR NOW + sizeof, volatileSaves, volatileRestores, hpRel, amodeToStix, amodeToStix', charLikeClosureSize, intLikeClosureSize, mutHS, dataHS, primToStix, macroCode, - heapCheck, codeGen, underscore, fmtAsmLbl, + heapCheck, +-- codeGen, underscore, fmtAsmLbl, UNUSED FOR NOW (done a diff way) -- and, for self-sufficiency... AbstractC, CAddrMode, CExprMacro, CStmtMacro, MagicId, @@ -49,57 +52,69 @@ Think of this as a big runtime class dictionary \begin{code} data Target = Target - (GlobalSwitch -> SwitchResult) -- switches +-- (GlobalSwitch -> SwitchResult) -- switches Int -- fixedHeaderSize (SMRep -> Int) -- varHeaderSize (MagicId -> RegLoc) -- stgReg - (StixTree -> StixTree) -- nativeOpt +-- (StixTree -> StixTree) -- nativeOpt (PrimKind -> Int) -- sizeof - ([MagicId] -> [StixTree]) -- volatileSaves - ([MagicId] -> [StixTree]) -- volatileRestores (HeapOffset -> Int) -- hpRel (CAddrMode -> StixTree) -- amodeToStix (CAddrMode -> StixTree) -- amodeToStix' - Int -- charLikeClosureSize - Int -- intLikeClosureSize - StixTree -- mutHS - StixTree -- dataHS - ([CAddrMode] -> PrimOp -> [CAddrMode] -> SUniqSM StixTreeList) + ( + ([MagicId] -> [StixTree]), -- volatileSaves + ([MagicId] -> [StixTree]), -- volatileRestores + Int, -- charLikeClosureSize + Int, -- intLikeClosureSize + StixTree, -- mutHS + StixTree, -- dataHS + ([CAddrMode] -> PrimOp -> [CAddrMode] -> SUniqSM StixTreeList), -- primToStix - (CStmtMacro -> [CAddrMode] -> SUniqSM StixTreeList) + (CStmtMacro -> [CAddrMode] -> SUniqSM StixTreeList), -- macroCode (StixTree -> StixTree -> StixTree -> SUniqSM StixTreeList) -- heapCheck - + ) +{- UNUSED: done a diff way: (PprStyle -> [[StixTree]] -> SUniqSM Unpretty) -- codeGen Bool -- underscore (String -> String) -- fmtAsmLbl +-} mkTarget = Target -targetSwitches (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = sw -fixedHeaderSize (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = fhs -varHeaderSize (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = vhs -stgReg (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = reg -nativeOpt (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = opt -sizeof (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = size -volatileSaves (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = vsave -volatileRestores (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = vrest -hpRel (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = hprel -amodeToStix (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = am -amodeToStix' (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = am' -charLikeClosureSize (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = csz -intLikeClosureSize (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = isz -mutHS (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = mhs -dataHS (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = dhs -primToStix (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = ps -macroCode (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = mc -heapCheck (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = hc -codeGen (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = cg -underscore (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = us -fmtAsmLbl (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = fmt +{- UNUSED FOR NOW: +targetSwitches (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x = {-sw-} x +-} +fixedHeaderSize (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) = fhs +varHeaderSize (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x = vhs x +stgReg (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x = reg x +{- UNUSED FOR NOW: +nativeOpt (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x = {-opt-} x +-} +sizeof (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x = size x +-- used only for wrapper-hungry PrimOps: +hpRel (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x = hprel x +amodeToStix (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x = am x +amodeToStix' (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x = am' x + +volatileSaves (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x = vsave x +-- used only for wrapper-hungry PrimOps: +volatileRestores (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x = vrest x +charLikeClosureSize (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) = csz +intLikeClosureSize (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) = isz +mutHS (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) = mhs +dataHS (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) = dhs +primToStix (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x y z = ps x y z +macroCode (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x y = mc x y +heapCheck (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x y z = hc x y z +{- UNUSED: done a diff way: +codeGen (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x y = cg x y +underscore (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) = us +fmtAsmLbl (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x = fmt x +-} \end{code} Trees for register save locations diff --git a/ghc/compiler/nativeGen/SparcCode.hi b/ghc/compiler/nativeGen/SparcCode.hi index 45e26296ce..a2004a4ee4 100644 --- a/ghc/compiler/nativeGen/SparcCode.hi +++ b/ghc/compiler/nativeGen/SparcCode.hi @@ -16,70 +16,41 @@ import UniqFM(UniqFM) import UniqSet(UniqSet(..)) import Unique(Unique) data Addr = AddrRegReg Reg Reg | AddrRegImm Reg Imm -data MagicId {-# GHC_PRAGMA BaseReg | StkOReg | VanillaReg PrimKind Int# | FloatReg Int# | DoubleReg Int# | TagReg | RetReg | SpA | SuA | SpB | SuB | Hp | HpLim | LivenessReg | ActivityReg | StdUpdRetVecReg | StkStubReg | CurCostCentre | VoidReg #-} -data Reg {-# GHC_PRAGMA FixedReg Int# | MappedReg Int# | MemoryReg Int PrimKind | UnmappedReg Unique PrimKind #-} -data BitSet {-# GHC_PRAGMA MkBS Word# #-} +data MagicId +data Reg +data BitSet data CLabel -data CSeq {-# GHC_PRAGMA CNil | CAppend CSeq CSeq | CIndent Int CSeq | CNewline | CStr [Char] | CCh Char | CInt Int | CPStr _PackedString #-} -data FiniteMap a b {-# GHC_PRAGMA EmptyFM | Branch a b Int# (FiniteMap a b) (FiniteMap a b) #-} -data OrdList a {-# GHC_PRAGMA SeqList (OrdList a) (OrdList a) | ParList (OrdList a) (OrdList a) | OrdObj a | NoObj #-} -data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-} -data CodeSegment {-# GHC_PRAGMA DataSegment | TextSegment #-} +data CSeq +data FiniteMap a b +data OrdList a +data PrimKind +data CodeSegment data Cond = ALWAYS | NEVER | GEU | LU | EQ | GT | GE | GU | LT | LE | LEU | NE | NEG | POS | VC | VS data Imm = ImmInt Int | ImmInteger Integer | ImmCLbl CLabel | ImmLab CSeq | ImmLit CSeq | LO Imm | HI Imm data RI = RIReg Reg | RIImm Imm data Size = SB | HW | UB | UHW | W | D | F | DF type SparcCode = OrdList SparcInstr data SparcInstr = LD Size Addr Reg | ST Size Reg Addr | ADD Bool Bool Reg RI Reg | SUB Bool Bool Reg RI Reg | AND Bool Reg RI Reg | ANDN Bool Reg RI Reg | OR Bool Reg RI Reg | ORN Bool Reg RI Reg | XOR Bool Reg RI Reg | XNOR Bool Reg RI Reg | SLL Reg RI Reg | SRL Reg RI Reg | SRA Reg RI Reg | SETHI Imm Reg | NOP | FABS Size Reg Reg | FADD Size Reg Reg Reg | FCMP Bool Size Reg Reg | FDIV Size Reg Reg Reg | FMOV Size Reg Reg | FMUL Size Reg Reg Reg | FNEG Size Reg Reg | FSQRT Size Reg Reg | FSUB Size Reg Reg Reg | FxTOy Size Size Reg Reg | BI Cond Bool Imm | BF Cond Bool Imm | JMP Addr | CALL Imm Int Bool | LABEL CLabel | COMMENT _PackedString | SEGMENT CodeSegment | ASCII Bool [Char] | DATA Size [Imm] -data SparcRegs {-# GHC_PRAGMA SRegs BitSet BitSet BitSet #-} -data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-} +data SparcRegs +data UniqFM a type UniqSet a = UniqFM a -data Unique {-# GHC_PRAGMA MkUnique Int# #-} +data Unique argRegs :: [Reg] - {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} baseRegOffset :: MagicId -> Int - {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} callerSaves :: MagicId -> Bool - {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} f0 :: Reg - {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} fp :: Reg - {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [30#] _N_ #-} freeRegs :: [Reg] - {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} g0 :: Reg - {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [0#] _N_ #-} is13Bits :: Integral a => a -> Bool - {-# GHC_PRAGMA _A_ 1 _U_ 12 _N_ _S_ "U(LU(U(ALASAAAA)AAA)AAAAAAAAAA)" {_A_ 3 _U_ 1112 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Int ] 1 { _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ }, [ Integer ] 1 { _A_ 1 _U_ 1 _N_ _S_ "U(PPP)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ } #-} kindToSize :: PrimKind -> Size - {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "E" _N_ _N_ #-} o0 :: Reg - {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} offset :: Addr -> Int -> Labda Addr - {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-} printLabeledCodes :: PprStyle -> [SparcInstr] -> CSeq - {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} reservedRegs :: [Int] - {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} sp :: Reg - {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [14#] _N_ #-} stgRegMap :: MagicId -> Labda Reg - {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} strImmLit :: [Char] -> Imm - {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} instance MachineCode SparcInstr - {-# GHC_PRAGMA _M_ SparcCode {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 6 _!_ _TUP_5 [(SparcInstr -> RegUsage), (SparcInstr -> RegLiveness -> RegLiveness), (SparcInstr -> (Reg -> Reg) -> SparcInstr), (Reg -> Reg -> OrdList SparcInstr), (Reg -> Reg -> OrdList SparcInstr)] [_CONSTM_ MachineCode regUsage (SparcInstr), _CONSTM_ MachineCode regLiveness (SparcInstr), _CONSTM_ MachineCode patchRegs (SparcInstr), _CONSTM_ MachineCode spillReg (SparcInstr), _CONSTM_ MachineCode loadReg (SparcInstr)] _N_ - regUsage = _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_, - regLiveness = _A_ 2 _U_ 11 _N_ _S_ "SU(LU(LL))" {_A_ 4 _U_ 1222 _N_ _N_ _N_ _N_} _N_ _N_, - patchRegs = _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_, - spillReg = _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_, - loadReg = _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-} instance MachineRegisters SparcRegs - {-# GHC_PRAGMA _M_ SparcCode {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 7 _!_ _TUP_6 [([Int] -> SparcRegs), (PrimKind -> SparcRegs -> [Int]), (SparcRegs -> Int# -> SparcRegs), (SparcRegs -> [Int] -> SparcRegs), (SparcRegs -> Int# -> SparcRegs), (SparcRegs -> [Int] -> SparcRegs)] [_CONSTM_ MachineRegisters mkMRegs (SparcRegs), _CONSTM_ MachineRegisters possibleMRegs (SparcRegs), _CONSTM_ MachineRegisters useMReg (SparcRegs), _CONSTM_ MachineRegisters useMRegs (SparcRegs), _CONSTM_ MachineRegisters freeMReg (SparcRegs), _CONSTM_ MachineRegisters freeMRegs (SparcRegs)] _N_ - mkMRegs = _A_ 1 _U_ 1 _N_ _N_ _N_ _N_, - possibleMRegs = _A_ 2 _U_ 11 _N_ _S_ "EU(LLL)" {_A_ 4 _U_ 1111 _N_ _N_ _N_ _N_} _N_ _N_, - useMReg = _A_ 2 _U_ 12 _N_ _S_ "U(LLL)P" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_, - useMRegs = _A_ 2 _U_ 11 _N_ _S_ "U(LLL)L" {_A_ 4 _U_ 1111 _N_ _N_ _N_ _N_} _N_ _N_, - freeMReg = _A_ 2 _U_ 12 _N_ _S_ "U(LLL)P" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_, - freeMRegs = _A_ 2 _U_ 11 _N_ _S_ "U(LLL)L" {_A_ 4 _U_ 1111 _N_ _N_ _N_ _N_} _N_ _N_ #-} diff --git a/ghc/compiler/nativeGen/SparcCode.lhs b/ghc/compiler/nativeGen/SparcCode.lhs index 1c3862e2c1..e068093f18 100644 --- a/ghc/compiler/nativeGen/SparcCode.lhs +++ b/ghc/compiler/nativeGen/SparcCode.lhs @@ -339,6 +339,7 @@ pprAddr sty (AddrRegReg r1 r2) = pprAddr sty (AddrRegImm r1 (ImmInt i)) | i == 0 = pprReg r1 + | i < -4096 || i > 4095 = large_offset_error i | i < 0 = uppBesides [ pprReg r1, @@ -348,6 +349,7 @@ pprAddr sty (AddrRegImm r1 (ImmInt i)) pprAddr sty (AddrRegImm r1 (ImmInteger i)) | i == 0 = pprReg r1 + | i < -4096 || i > 4095 = large_offset_error i | i < 0 = uppBesides [ pprReg r1, @@ -362,6 +364,9 @@ pprAddr sty (AddrRegImm r1 imm) = pprImm sty imm ] +large_offset_error i + = error ("ERROR: SPARC native-code generator cannot handle large offset ("++show i++");\nprobably because of large constant data structures;\nworkaround: use -fvia-C on this module.\n") + pprRI :: PprStyle -> RI -> Unpretty pprRI sty (RIReg r) = pprReg r pprRI sty (RIImm r) = pprImm sty r @@ -1098,7 +1103,7 @@ baseRegOffset SuB = OFFSET_SuB baseRegOffset Hp = OFFSET_Hp baseRegOffset HpLim = OFFSET_HpLim baseRegOffset LivenessReg = OFFSET_Liveness -baseRegOffset ActivityReg = OFFSET_Activity +--baseRegOffset ActivityReg = OFFSET_Activity #ifdef DEBUG baseRegOffset BaseReg = panic "baseRegOffset:BaseReg" baseRegOffset StdUpdRetVecReg = panic "baseRegOffset:StgUpdRetVecReg" @@ -1184,7 +1189,7 @@ callerSaves HpLim = True callerSaves LivenessReg = True #endif #ifdef CALLER_SAVES_Activity -callerSaves ActivityReg = True +--callerSaves ActivityReg = True #endif #ifdef CALLER_SAVES_StdUpdRetVec callerSaves StdUpdRetVecReg = True @@ -1271,7 +1276,7 @@ stgRegMap HpLim = Just (FixedReg ILIT(REG_HpLim)) stgRegMap LivenessReg = Just (FixedReg ILIT(REG_Liveness)) #endif #ifdef REG_Activity -stgRegMap ActivityReg = Just (FixedReg ILIT(REG_Activity)) +--stgRegMap ActivityReg = Just (FixedReg ILIT(REG_Activity)) #endif #ifdef REG_StdUpdRetVec stgRegMap StdUpdRetVecReg = Just (FixedReg ILIT(REG_StdUpdRetVec)) @@ -1372,7 +1377,7 @@ freeReg ILIT(REG_HpLim) = _FALSE_ freeReg ILIT(REG_Liveness) = _FALSE_ #endif #ifdef REG_Activity -freeReg ILIT(REG_Activity) = _FALSE_ +--freeReg ILIT(REG_Activity) = _FALSE_ #endif #ifdef REG_StdUpdRetVec freeReg ILIT(REG_StdUpdRetVec) = _FALSE_ diff --git a/ghc/compiler/nativeGen/SparcDesc.hi b/ghc/compiler/nativeGen/SparcDesc.hi index ae4c32d836..9d40f7ca7f 100644 --- a/ghc/compiler/nativeGen/SparcDesc.hi +++ b/ghc/compiler/nativeGen/SparcDesc.hi @@ -11,14 +11,14 @@ import Pretty(PprStyle) import PrimKind(PrimKind) import PrimOps(PrimOp) import SMRep(SMRep, SMSpecRepKind, SMUpdateKind) +import SplitUniq(SplitUniqSupply) import Stix(CodeSegment, StixReg, StixTree) -data MagicId {-# GHC_PRAGMA BaseReg | StkOReg | VanillaReg PrimKind Int# | FloatReg Int# | DoubleReg Int# | TagReg | RetReg | SpA | SuA | SpB | SuB | Hp | HpLim | LivenessReg | ActivityReg | StdUpdRetVecReg | StkStubReg | CurCostCentre | VoidReg #-} -data SwitchResult {-# GHC_PRAGMA SwBool Bool | SwString [Char] | SwInt Int #-} -data RegLoc {-# GHC_PRAGMA Save StixTree | Always StixTree #-} -data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-} -data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-} -data SMRep {-# GHC_PRAGMA StaticRep Int Int | SpecialisedRep SMSpecRepKind Int Int SMUpdateKind | GenericRep Int Int SMUpdateKind | BigTupleRep Int | DataRep Int | DynamicRep | BlackHoleRep | PhantomRep | MuTupleRep Int #-} -data StixTree {-# GHC_PRAGMA StSegment CodeSegment | StInt Integer | StDouble (Ratio Integer) | StString _PackedString | StLitLbl CSeq | StLitLit _PackedString | StCLbl CLabel | StReg StixReg | StIndex PrimKind StixTree StixTree | StInd PrimKind StixTree | StAssign PrimKind StixTree StixTree | StLabel CLabel | StFunBegin CLabel | StFunEnd CLabel | StJump StixTree | StFallThrough CLabel | StCondJump CLabel StixTree | StData PrimKind [StixTree] | StPrim PrimOp [StixTree] | StCall _PackedString PrimKind [StixTree] | StComment _PackedString #-} -mkSparc :: Bool -> (GlobalSwitch -> SwitchResult) -> Target - {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +data MagicId +data SwitchResult +data RegLoc +data PprStyle +data PrimKind +data SMRep +data StixTree +mkSparc :: Bool -> (GlobalSwitch -> SwitchResult) -> (Target, PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq, Bool, [Char] -> [Char]) diff --git a/ghc/compiler/nativeGen/SparcDesc.lhs b/ghc/compiler/nativeGen/SparcDesc.lhs index 91f2d9e4f7..0a0de397be 100644 --- a/ghc/compiler/nativeGen/SparcDesc.lhs +++ b/ghc/compiler/nativeGen/SparcDesc.lhs @@ -120,7 +120,7 @@ because some are reloaded from constants. \begin{code} vsaves switches vols = - map save ((filter callerSaves) ([BaseReg,SpA,SuA,SpB,SuB,Hp,HpLim,RetReg,ActivityReg] ++ vols)) + map save ((filter callerSaves) ([BaseReg,SpA,SuA,SpB,SuB,Hp,HpLim,RetReg{-,ActivityReg-}] ++ vols)) where save x = StAssign (kindFromMagicId x) loc reg where reg = StReg (StixMagicId x) @@ -130,7 +130,7 @@ vsaves switches vols = vrests switches vols = map restore ((filter callerSaves) - ([BaseReg,SpA,SuA,SpB,SuB,Hp,HpLim,RetReg,ActivityReg,StkStubReg,StdUpdRetVecReg] ++ vols)) + ([BaseReg,SpA,SuA,SpB,SuB,Hp,HpLim,RetReg{-,ActivityReg-},StkStubReg,StdUpdRetVecReg] ++ vols)) where restore x = StAssign (kindFromMagicId x) reg loc where reg = StReg (StixMagicId x) @@ -170,10 +170,16 @@ Setting up a sparc target. \begin{code} -mkSparc :: Bool -> (GlobalSwitch -> SwitchResult) -> Target +mkSparc :: Bool + -> (GlobalSwitch -> SwitchResult) + -> (Target, + (PprStyle -> [[StixTree]] -> SUniqSM Unpretty), -- codeGen + Bool, -- underscore + (String -> String)) -- fmtAsmLbl mkSparc decentOS switches = - let fhs' = fhs switches + let + fhs' = fhs switches vhs' = vhs switches sparcReg' = sparcReg switches vsaves' = vsaves switches @@ -187,13 +193,11 @@ mkSparc decentOS switches = dhs' = dhs switches ps = genPrimCode target mc = genMacroCode target - hc = doHeapCheck target - target = mkTarget switches fhs' vhs' sparcReg' id size vsaves' vrests' - hprel as as' csz isz mhs' dhs' ps mc hc - sparcCodeGen decentOS id - in target - + hc = doHeapCheck --UNUSED NOW: target + target = mkTarget {-switches-} fhs' vhs' sparcReg' {-id-} size + hprel as as' + (vsaves', vrests', csz, isz, mhs', dhs', ps, mc, hc) + {-sparcCodeGen decentOS id-} + in + (target, sparcCodeGen, decentOS, id) \end{code} - - - diff --git a/ghc/compiler/nativeGen/SparcGen.hi b/ghc/compiler/nativeGen/SparcGen.hi index f4bc7f088d..2a32fbcc63 100644 --- a/ghc/compiler/nativeGen/SparcGen.hi +++ b/ghc/compiler/nativeGen/SparcGen.hi @@ -10,9 +10,8 @@ import PrimKind(PrimKind) import PrimOps(PrimOp) import SplitUniq(SplitUniqSupply) import Stix(CodeSegment, StixReg, StixTree) -data CSeq {-# GHC_PRAGMA CNil | CAppend CSeq CSeq | CIndent Int CSeq | CNewline | CStr [Char] | CCh Char | CInt Int | CPStr _PackedString #-} -data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-} -data StixTree {-# GHC_PRAGMA StSegment CodeSegment | StInt Integer | StDouble (Ratio Integer) | StString _PackedString | StLitLbl CSeq | StLitLit _PackedString | StCLbl CLabel | StReg StixReg | StIndex PrimKind StixTree StixTree | StInd PrimKind StixTree | StAssign PrimKind StixTree StixTree | StLabel CLabel | StFunBegin CLabel | StFunEnd CLabel | StJump StixTree | StFallThrough CLabel | StCondJump CLabel StixTree | StData PrimKind [StixTree] | StPrim PrimOp [StixTree] | StCall _PackedString PrimKind [StixTree] | StComment _PackedString #-} +data CSeq +data PprStyle +data StixTree sparcCodeGen :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq - {-# GHC_PRAGMA _A_ 2 _U_ 211 _N_ _S_ "LS" _N_ _N_ #-} diff --git a/ghc/compiler/nativeGen/SparcGen.lhs b/ghc/compiler/nativeGen/SparcGen.lhs index f5bc3a032c..b271591dec 100644 --- a/ghc/compiler/nativeGen/SparcGen.lhs +++ b/ghc/compiler/nativeGen/SparcGen.lhs @@ -308,7 +308,6 @@ getReg (StPrim primop args) = IntSubOp -> trivialCode (SUB False False) args IntMulOp -> call SLIT(".umul") IntKind IntQuotOp -> call SLIT(".div") IntKind - IntDivOp -> call SLIT("stg_div") IntKind IntRemOp -> call SLIT(".rem") IntKind IntNegOp -> trivialUCode (SUB False False g0) args IntAbsOp -> absIntCode args diff --git a/ghc/compiler/nativeGen/Stix.hi b/ghc/compiler/nativeGen/Stix.hi index 12f22110fd..4f371d17e7 100644 --- a/ghc/compiler/nativeGen/Stix.hi +++ b/ghc/compiler/nativeGen/Stix.hi @@ -10,54 +10,32 @@ import PrimOps(PrimOp) import SplitUniq(SUniqSM(..), SplitUniqSupply) import UniType(UniType) import Unique(Unique) -data MagicId {-# GHC_PRAGMA BaseReg | StkOReg | VanillaReg PrimKind Int# | FloatReg Int# | DoubleReg Int# | TagReg | RetReg | SpA | SuA | SpB | SuB | Hp | HpLim | LivenessReg | ActivityReg | StdUpdRetVecReg | StkStubReg | CurCostCentre | VoidReg #-} +data MagicId data CLabel data CodeSegment = DataSegment | TextSegment -data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-} -data PrimOp - {-# GHC_PRAGMA 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 | OrdOp | ChrOp | IntAddOp | IntSubOp | IntMulOp | IntQuotOp | IntDivOp | IntRemOp | IntNegOp | IntAbsOp | AndOp | OrOp | NotOp | SllOp | SraOp | SrlOp | ISllOp | ISraOp | ISrlOp | Int2WordOp | Word2IntOp | Int2AddrOp | Addr2IntOp | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp | Float2IntOp | Int2FloatOp | FloatExpOp | FloatLogOp | FloatSqrtOp | FloatSinOp | FloatCosOp | FloatTanOp | FloatAsinOp | FloatAcosOp | FloatAtanOp | FloatSinhOp | FloatCoshOp | FloatTanhOp | FloatPowerOp | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp | Double2IntOp | Int2DoubleOp | Double2FloatOp | Float2DoubleOp | DoubleExpOp | DoubleLogOp | DoubleSqrtOp | DoubleSinOp | DoubleCosOp | DoubleTanOp | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp | DoublePowerOp | IntegerAddOp | IntegerSubOp | IntegerMulOp | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp | IntegerCmpOp | Integer2IntOp | Int2IntegerOp | Word2IntegerOp | Addr2IntegerOp | FloatEncodeOp | FloatDecodeOp | DoubleEncodeOp | DoubleDecodeOp | NewArrayOp | NewByteArrayOp PrimKind | SameMutableArrayOp | SameMutableByteArrayOp | ReadArrayOp | WriteArrayOp | IndexArrayOp | ReadByteArrayOp PrimKind | WriteByteArrayOp PrimKind | IndexByteArrayOp PrimKind | IndexOffAddrOp PrimKind | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp | NewSynchVarOp | TakeMVarOp | PutMVarOp | ReadIVarOp | WriteIVarOp | MakeStablePtrOp | DeRefStablePtrOp | CCallOp _PackedString Bool Bool [UniType] UniType | ErrorIOPrimOp | ReallyUnsafePtrEqualityOp | SeqOp | ParOp | ForkOp | DelayOp | WaitOp #-} +data PrimKind +data PrimOp type SUniqSM a = SplitUniqSupply -> a -data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-} +data SplitUniqSupply data StixReg = StixMagicId MagicId | StixTemp Unique PrimKind data StixTree = StSegment CodeSegment | StInt Integer | StDouble (Ratio Integer) | StString _PackedString | StLitLbl CSeq | StLitLit _PackedString | StCLbl CLabel | StReg StixReg | StIndex PrimKind StixTree StixTree | StInd PrimKind StixTree | StAssign PrimKind StixTree StixTree | StLabel CLabel | StFunBegin CLabel | StFunEnd CLabel | StJump StixTree | StFallThrough CLabel | StCondJump CLabel StixTree | StData PrimKind [StixTree] | StPrim PrimOp [StixTree] | StCall _PackedString PrimKind [StixTree] | StComment _PackedString type StixTreeList = [StixTree] -> [StixTree] -data Unique {-# GHC_PRAGMA MkUnique Int# #-} +data Unique getUniqLabelNCG :: SplitUniqSupply -> CLabel - {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(ALA)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-} sStLitLbl :: _PackedString -> StixTree - {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} -stgActivityReg :: StixTree - {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} stgBaseReg :: StixTree - {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} stgHp :: StixTree - {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} stgHpLim :: StixTree - {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} stgLivenessReg :: StixTree - {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} stgNode :: StixTree - {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} stgRetReg :: StixTree - {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} stgSpA :: StixTree - {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} stgSpB :: StixTree - {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} stgStdUpdRetVecReg :: StixTree - {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} stgStkOReg :: StixTree - {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} stgStkStubReg :: StixTree - {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} stgSuA :: StixTree - {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} stgSuB :: StixTree - {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} stgTagReg :: StixTree - {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} instance Eq CodeSegment - {-# GHC_PRAGMA _M_ Stix {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(CodeSegment -> CodeSegment -> Bool), (CodeSegment -> CodeSegment -> Bool)] [_CONSTM_ Eq (==) (CodeSegment), _CONSTM_ Eq (/=) (CodeSegment)] _N_ - (==) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_, - (/=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-} diff --git a/ghc/compiler/nativeGen/Stix.lhs b/ghc/compiler/nativeGen/Stix.lhs index 321e58d21b..e2d4aa7b4e 100644 --- a/ghc/compiler/nativeGen/Stix.lhs +++ b/ghc/compiler/nativeGen/Stix.lhs @@ -11,7 +11,8 @@ module Stix ( stgBaseReg, stgStkOReg, stgNode, stgTagReg, stgRetReg, stgSpA, stgSuA, stgSpB, stgSuB, stgHp, stgHpLim, stgLivenessReg, - stgActivityReg, stgStdUpdRetVecReg, stgStkStubReg, +-- stgActivityReg, + stgStdUpdRetVecReg, stgStkStubReg, getUniqLabelNCG, -- And for self-sufficiency, by golly... @@ -147,7 +148,7 @@ type StixTreeList = [StixTree] -> [StixTree] \begin{code} stgBaseReg, stgStkOReg, stgNode, stgTagReg, stgRetReg, stgSpA, stgSuA, - stgSpB, stgSuB, stgHp, stgHpLim, stgLivenessReg, stgActivityReg, stgStdUpdRetVecReg, + stgSpB, stgSuB, stgHp, stgHpLim, stgLivenessReg{-, stgActivityReg-}, stgStdUpdRetVecReg, stgStkStubReg :: StixTree stgBaseReg = StReg (StixMagicId BaseReg) @@ -163,7 +164,7 @@ stgSuB = StReg (StixMagicId SuB) stgHp = StReg (StixMagicId Hp) stgHpLim = StReg (StixMagicId HpLim) stgLivenessReg = StReg (StixMagicId LivenessReg) -stgActivityReg = StReg (StixMagicId ActivityReg) +--stgActivityReg = StReg (StixMagicId ActivityReg) stgStdUpdRetVecReg = StReg (StixMagicId StdUpdRetVecReg) stgStkStubReg = StReg (StixMagicId StkStubReg) diff --git a/ghc/compiler/nativeGen/StixInfo.hi b/ghc/compiler/nativeGen/StixInfo.hi index 3856c3d1dc..686d508700 100644 --- a/ghc/compiler/nativeGen/StixInfo.hi +++ b/ghc/compiler/nativeGen/StixInfo.hi @@ -1,9 +1,8 @@ {-# GHC_PRAGMA INTERFACE VERSION 5 #-} interface StixInfo where -import AbsCSyn(AbstractC) -import MachDesc(Target) +import AbsCSyn(AbstractC, CAddrMode) +import HeapOffs(HeapOffset) import SplitUniq(SplitUniqSupply) import Stix(StixTree) -genCodeInfoTable :: Target -> AbstractC -> SplitUniqSupply -> [StixTree] -> [StixTree] - {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ #-} +genCodeInfoTable :: (HeapOffset -> Int) -> (CAddrMode -> StixTree) -> AbstractC -> SplitUniqSupply -> [StixTree] -> [StixTree] diff --git a/ghc/compiler/nativeGen/StixInfo.lhs b/ghc/compiler/nativeGen/StixInfo.lhs index 9f1747fb10..b976193ff5 100644 --- a/ghc/compiler/nativeGen/StixInfo.lhs +++ b/ghc/compiler/nativeGen/StixInfo.lhs @@ -37,11 +37,13 @@ data___rtbl = sStLitLbl SLIT("Data___rtbl") dyn___rtbl = sStLitLbl SLIT("Dyn___rtbl") genCodeInfoTable - :: Target + :: {-Target-} + (HeapOffset -> Int) -- needed bit of Target + -> (CAddrMode -> StixTree) -- ditto -> AbstractC -> SUniqSM StixTreeList -genCodeInfoTable target (CClosureInfoAndCode cl_info _ _ upd cl_descr) = +genCodeInfoTable hp_rel amode2stix (CClosureInfoAndCode cl_info _ _ upd cl_descr _) = returnSUs (\xs -> info : lbl : xs) where @@ -132,10 +134,10 @@ genCodeInfoTable target (CClosureInfoAndCode cl_info _ _ upd cl_descr) = size = if isSpecRep sm_rep then closureNonHdrSize cl_info - else hpRel target (closureSizeWithoutFixedHdr cl_info) + else hp_rel (closureSizeWithoutFixedHdr cl_info) ptrs = closurePtrsSize cl_info - upd_code = amodeToStix target upd + upd_code = amode2stix upd info_unused = StInt (-1) diff --git a/ghc/compiler/nativeGen/StixInteger.hi b/ghc/compiler/nativeGen/StixInteger.hi index 9e8314501f..889d352aa6 100644 --- a/ghc/compiler/nativeGen/StixInteger.hi +++ b/ghc/compiler/nativeGen/StixInteger.hi @@ -6,22 +6,13 @@ import PreludePS(_PackedString) import PrimKind(PrimKind) import SplitUniq(SplitUniqSupply) import Stix(StixTree) -decodeFloatingKind :: PrimKind -> Target -> [CAddrMode] -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree] - {-# GHC_PRAGMA _A_ 4 _U_ 121102 _N_ _N_ _N_ _N_ #-} -encodeFloatingKind :: PrimKind -> Target -> [CAddrMode] -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree] - {-# GHC_PRAGMA _A_ 4 _U_ 121122 _N_ _S_ "LLSL" _N_ _N_ #-} -gmpCompare :: Target -> CAddrMode -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree] - {-# GHC_PRAGMA _A_ 3 _U_ 22102 _N_ _N_ _N_ _N_ #-} -gmpInt2Integer :: Target -> [CAddrMode] -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree] - {-# GHC_PRAGMA _A_ 3 _U_ 21122 _N_ _S_ "LLS" _N_ _N_ #-} -gmpInteger2Int :: Target -> CAddrMode -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree] - {-# GHC_PRAGMA _A_ 3 _U_ 22102 _N_ _N_ _N_ _N_ #-} -gmpString2Integer :: Target -> [CAddrMode] -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree] - {-# GHC_PRAGMA _A_ 3 _U_ 21122 _N_ _S_ "U(ALLLAAAAALAAAALASAAAA)LS" _N_ _N_ #-} -gmpTake1Return1 :: Target -> [CAddrMode] -> _PackedString -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree] - {-# GHC_PRAGMA _A_ 4 _U_ 212122 _N_ _S_ "U(AAALAAAAALAAAALAASAAA)LLL" _N_ _N_ #-} -gmpTake2Return1 :: Target -> [CAddrMode] -> _PackedString -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree] - {-# GHC_PRAGMA _A_ 4 _U_ 212122 _N_ _S_ "U(AAALAAAAALAAAALAASAAA)LLL" _N_ _N_ #-} -gmpTake2Return2 :: Target -> [CAddrMode] -> _PackedString -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree] - {-# GHC_PRAGMA _A_ 4 _U_ 212122 _N_ _S_ "U(AAALAAAAALAAAALAASAAA)LLL" _N_ _N_ #-} +decodeFloatingKind :: PrimKind -> Target -> (CAddrMode, CAddrMode, CAddrMode, CAddrMode) -> (CAddrMode, CAddrMode) -> SplitUniqSupply -> [StixTree] -> [StixTree] +encodeFloatingKind :: PrimKind -> Target -> CAddrMode -> (CAddrMode, CAddrMode, CAddrMode, CAddrMode, CAddrMode) -> SplitUniqSupply -> [StixTree] -> [StixTree] +gmpCompare :: Target -> CAddrMode -> (CAddrMode, CAddrMode, CAddrMode, CAddrMode, CAddrMode, CAddrMode, CAddrMode) -> SplitUniqSupply -> [StixTree] -> [StixTree] +gmpInt2Integer :: Target -> (CAddrMode, CAddrMode, CAddrMode) -> (CAddrMode, CAddrMode) -> SplitUniqSupply -> [StixTree] -> [StixTree] +gmpInteger2Int :: Target -> CAddrMode -> (CAddrMode, CAddrMode, CAddrMode, CAddrMode) -> SplitUniqSupply -> [StixTree] -> [StixTree] +gmpString2Integer :: Target -> (CAddrMode, CAddrMode, CAddrMode) -> (CAddrMode, CAddrMode) -> SplitUniqSupply -> [StixTree] -> [StixTree] +gmpTake1Return1 :: Target -> (CAddrMode, CAddrMode, CAddrMode) -> _PackedString -> (CAddrMode, CAddrMode, CAddrMode, CAddrMode) -> SplitUniqSupply -> [StixTree] -> [StixTree] +gmpTake2Return1 :: Target -> (CAddrMode, CAddrMode, CAddrMode) -> _PackedString -> (CAddrMode, CAddrMode, CAddrMode, CAddrMode, CAddrMode, CAddrMode, CAddrMode) -> SplitUniqSupply -> [StixTree] -> [StixTree] +gmpTake2Return2 :: Target -> (CAddrMode, CAddrMode, CAddrMode, CAddrMode, CAddrMode, CAddrMode) -> _PackedString -> (CAddrMode, CAddrMode, CAddrMode, CAddrMode, CAddrMode, CAddrMode, CAddrMode) -> SplitUniqSupply -> [StixTree] -> [StixTree] diff --git a/ghc/compiler/nativeGen/StixInteger.lhs b/ghc/compiler/nativeGen/StixInteger.lhs index 1051d26153..a5268beab7 100644 --- a/ghc/compiler/nativeGen/StixInteger.lhs +++ b/ghc/compiler/nativeGen/StixInteger.lhs @@ -33,9 +33,10 @@ import Util gmpTake1Return1 :: Target - -> [CAddrMode] -- result (3 parts) - -> FAST_STRING -- function name - -> [CAddrMode] -- argument (3 parts) + -> (CAddrMode,CAddrMode,CAddrMode) -- result (3 parts) + -> FAST_STRING -- function name + -> (CAddrMode, CAddrMode,CAddrMode,CAddrMode) + -- argument (4 parts) -> SUniqSM StixTreeList argument1 = mpStruct 1 -- out here to avoid CAF (sigh) @@ -47,46 +48,71 @@ init2 = StCall SLIT("mpz_init") VoidKind [result2] init3 = StCall SLIT("mpz_init") VoidKind [result3] init4 = StCall SLIT("mpz_init") VoidKind [result4] -gmpTake1Return1 target res rtn arg = - let [ar,sr,dr] = map (amodeToStix target) res - [liveness, aa,sa,da] = map (amodeToStix target) arg - space = mpSpace target 2 1 [sa] +-- hacking with Uncle Will: +#define target_STRICT target@(Target _ _ _ _ _ _ _ _) + +gmpTake1Return1 target_STRICT res@(car,csr,cdr) rtn arg@(clive,caa,csa,cda) = + let + a2stix = amodeToStix target + data_hs = dataHS target + + ar = a2stix car + sr = a2stix csr + dr = a2stix cdr + liveness= a2stix clive + aa = a2stix caa + sa = a2stix csa + da = a2stix cda + + space = mpSpace data_hs 2 1 [sa] oldHp = StIndex PtrKind stgHp (StPrim IntNegOp [space]) safeHp = saveLoc target Hp save = StAssign PtrKind safeHp oldHp - (a1,a2,a3) = toStruct target argument1 (aa,sa,da) + (a1,a2,a3) = toStruct data_hs argument1 (aa,sa,da) mpz_op = StCall rtn VoidKind [result2, argument1] restore = StAssign PtrKind stgHp safeHp - (r1,r2,r3) = fromStruct target result2 (ar,sr,dr) + (r1,r2,r3) = fromStruct data_hs result2 (ar,sr,dr) in - heapCheck target liveness space (StInt 0) - `thenSUs` \ heap_chk -> + heapCheck target liveness space (StInt 0) `thenSUs` \ heap_chk -> returnSUs (heap_chk . (\xs -> a1 : a2 : a3 : save : init2 : mpz_op : r1 : r2 : r3 : restore : xs)) gmpTake2Return1 :: Target - -> [CAddrMode] -- result (3 parts) - -> FAST_STRING -- function name - -> [CAddrMode] -- arguments (3 parts each) + -> (CAddrMode,CAddrMode,CAddrMode) -- result (3 parts) + -> FAST_STRING -- function name + -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode) + -- liveness + 2 arguments (3 parts each) -> SUniqSM StixTreeList -gmpTake2Return1 target res rtn args = - let [ar,sr,dr] = map (amodeToStix target) res - [liveness, aa1,sa1,da1, aa2,sa2,da2] = map (amodeToStix target) args - space = mpSpace target 3 1 [sa1, sa2] +gmpTake2Return1 target_STRICT res@(car,csr,cdr) rtn args@(clive, caa1,csa1,cda1, caa2,csa2,cda2) = + let + a2stix = amodeToStix target + data_hs = dataHS target + + ar = a2stix car + sr = a2stix csr + dr = a2stix cdr + liveness= a2stix clive + aa1 = a2stix caa1 + sa1 = a2stix csa1 + da1 = a2stix cda1 + aa2 = a2stix caa2 + sa2 = a2stix csa2 + da2 = a2stix cda2 + + space = mpSpace data_hs 3 1 [sa1, sa2] oldHp = StIndex PtrKind stgHp (StPrim IntNegOp [space]) safeHp = saveLoc target Hp save = StAssign PtrKind safeHp oldHp - (a1,a2,a3) = toStruct target argument1 (aa1,sa1,da1) - (a4,a5,a6) = toStruct target argument2 (aa2,sa2,da2) + (a1,a2,a3) = toStruct data_hs argument1 (aa1,sa1,da1) + (a4,a5,a6) = toStruct data_hs argument2 (aa2,sa2,da2) mpz_op = StCall rtn VoidKind [result3, argument1, argument2] restore = StAssign PtrKind stgHp safeHp - (r1,r2,r3) = fromStruct target result3 (ar,sr,dr) + (r1,r2,r3) = fromStruct data_hs result3 (ar,sr,dr) in - heapCheck target liveness space (StInt 0) - `thenSUs` \ heap_chk -> + heapCheck target liveness space (StInt 0) `thenSUs` \ heap_chk -> returnSUs (heap_chk . (\xs -> a1 : a2 : a3 : a4 : a5 : a6 @@ -94,28 +120,46 @@ gmpTake2Return1 target res rtn args = gmpTake2Return2 :: Target - -> [CAddrMode] -- results (3 parts each) + -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode) + -- 2 results (3 parts each) -> FAST_STRING -- function name - -> [CAddrMode] -- arguments (3 parts each) + -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode) + -- liveness + 2 arguments (3 parts each) -> SUniqSM StixTreeList -gmpTake2Return2 target res rtn args = - let [ar1,sr1,dr1, ar2,sr2,dr2] = map (amodeToStix target) res - [liveness, aa1,sa1,da1, aa2,sa2,da2] = map (amodeToStix target) args - space = StPrim IntMulOp [mpSpace target 2 1 [sa1, sa2], StInt 2] +gmpTake2Return2 target_STRICT res@(car1,csr1,cdr1, car2,csr2,cdr2) + rtn args@(clive, caa1,csa1,cda1, caa2,csa2,cda2) = + let + a2stix = amodeToStix target + data_hs = dataHS target + + ar1 = a2stix car1 + sr1 = a2stix csr1 + dr1 = a2stix cdr1 + ar2 = a2stix car2 + sr2 = a2stix csr2 + dr2 = a2stix cdr2 + liveness= a2stix clive + aa1 = a2stix caa1 + sa1 = a2stix csa1 + da1 = a2stix cda1 + aa2 = a2stix caa2 + sa2 = a2stix csa2 + da2 = a2stix cda2 + + space = StPrim IntMulOp [mpSpace data_hs 2 1 [sa1, sa2], StInt 2] oldHp = StIndex PtrKind stgHp (StPrim IntNegOp [space]) safeHp = saveLoc target Hp save = StAssign PtrKind safeHp oldHp - (a1,a2,a3) = toStruct target argument1 (aa1,sa1,da1) - (a4,a5,a6) = toStruct target argument2 (aa2,sa2,da2) + (a1,a2,a3) = toStruct data_hs argument1 (aa1,sa1,da1) + (a4,a5,a6) = toStruct data_hs argument2 (aa2,sa2,da2) mpz_op = StCall rtn VoidKind [result3, result4, argument1, argument2] restore = StAssign PtrKind stgHp safeHp - (r1,r2,r3) = fromStruct target result3 (ar1,sr1,dr1) - (r4,r5,r6) = fromStruct target result4 (ar2,sr2,dr2) + (r1,r2,r3) = fromStruct data_hs result3 (ar1,sr1,dr1) + (r4,r5,r6) = fromStruct data_hs result4 (ar2,sr2,dr2) in - heapCheck target liveness space (StInt 0) - `thenSUs` \ heap_chk -> + heapCheck target liveness space (StInt 0) `thenSUs` \ heap_chk -> returnSUs (heap_chk . (\xs -> a1 : a2 : a3 : a4 : a5 : a6 @@ -124,26 +168,38 @@ gmpTake2Return2 target res rtn args = \end{code} -Although gmpCompare doesn't allocate space, it does temporarily use some -space just beyond the heap pointer. This is safe, because the enclosing -routine has already guaranteed that this space will be available. -(See ``primOpHeapRequired.'') +Although gmpCompare doesn't allocate space, it does temporarily use +some space just beyond the heap pointer. This is safe, because the +enclosing routine has already guaranteed that this space will be +available. (See ``primOpHeapRequired.'') \begin{code} gmpCompare :: Target -> CAddrMode -- result (boolean) - -> [CAddrMode] -- arguments (3 parts each) + -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode) + -- alloc hp + 2 arguments (3 parts each) -> SUniqSM StixTreeList -gmpCompare target res args = - let result = amodeToStix target res - [hp, aa1,sa1,da1, aa2,sa2,da2] = map (amodeToStix target) args +gmpCompare target_STRICT res args@(chp, caa1,csa1,cda1, caa2,csa2,cda2) = + let + a2stix = amodeToStix target + data_hs = dataHS target + + result = a2stix res + hp = a2stix chp + aa1 = a2stix caa1 + sa1 = a2stix csa1 + da1 = a2stix cda1 + aa2 = a2stix caa2 + sa2 = a2stix csa2 + da2 = a2stix cda2 + argument1 = hp argument2 = StIndex IntKind hp (StInt (toInteger mpIntSize)) - (a1,a2,a3) = toStruct target argument1 (aa1,sa1,da1) - (a4,a5,a6) = toStruct target argument2 (aa2,sa2,da2) + (a1,a2,a3) = toStruct data_hs argument1 (aa1,sa1,da1) + (a4,a5,a6) = toStruct data_hs argument2 (aa2,sa2,da2) mpz_cmp = StCall SLIT("mpz_cmp") IntKind [argument1, argument2] r1 = StAssign IntKind result mpz_cmp in @@ -158,13 +214,21 @@ See the comment above regarding the heap check (or lack thereof). gmpInteger2Int :: Target -> CAddrMode -- result - -> [CAddrMode] -- argument (3 parts) + -> (CAddrMode, CAddrMode,CAddrMode,CAddrMode) -- alloc hp + argument (3 parts) -> SUniqSM StixTreeList -gmpInteger2Int target res args = - let result = amodeToStix target res - [hp, aa,sa,da] = map (amodeToStix target) args - (a1,a2,a3) = toStruct target hp (aa,sa,da) +gmpInteger2Int target_STRICT res args@(chp, caa,csa,cda) = + let + a2stix = amodeToStix target + data_hs = dataHS target + + result = a2stix res + hp = a2stix chp + aa = a2stix caa + sa = a2stix csa + da = a2stix cda + + (a1,a2,a3) = toStruct data_hs hp (aa,sa,da) mpz_get_si = StCall SLIT("mpz_get_si") IntKind [hp] r1 = StAssign IntKind result mpz_get_si in @@ -174,16 +238,23 @@ arrayOfData_info = sStLitLbl SLIT("ArrayOfData_info") gmpInt2Integer :: Target - -> [CAddrMode] -- result (3 parts) - -> [CAddrMode] -- allocated heap, int to convert + -> (CAddrMode, CAddrMode, CAddrMode) -- result (3 parts) + -> (CAddrMode, CAddrMode) -- allocated heap, Int to convert -> SUniqSM StixTreeList -gmpInt2Integer target res args@[_, n] = - getUniqLabelNCG `thenSUs` \ zlbl -> - getUniqLabelNCG `thenSUs` \ nlbl -> - getUniqLabelNCG `thenSUs` \ jlbl -> - let [ar,sr,dr] = map (amodeToStix target) res - [hp, i] = map (amodeToStix target) args +gmpInt2Integer target_STRICT res@(car,csr,cdr) args@(chp, n) = + getUniqLabelNCG `thenSUs` \ zlbl -> + getUniqLabelNCG `thenSUs` \ nlbl -> + getUniqLabelNCG `thenSUs` \ jlbl -> + let + a2stix = amodeToStix target + + ar = a2stix car + sr = a2stix csr + dr = a2stix cdr + hp = a2stix chp + i = a2stix n + h1 = StAssign PtrKind (StInd PtrKind hp) arrayOfData_info size = varHeaderSize target (DataRep 0) + mIN_MP_INT_SIZE h2 = StAssign IntKind (StInd IntKind (StIndex IntKind hp (StInt 1))) @@ -222,13 +293,20 @@ gmpInt2Integer target res args@[_, n] = gmpString2Integer :: Target - -> [CAddrMode] -- result (3 parts) - -> [CAddrMode] -- liveness, string + -> (CAddrMode, CAddrMode, CAddrMode) -- result (3 parts) + -> (CAddrMode, CAddrMode) -- liveness, string -> SUniqSM StixTreeList -gmpString2Integer target res [liveness, str] = +gmpString2Integer target_STRICT res@(car,csr,cdr) (liveness, str) = getUniqLabelNCG `thenSUs` \ ulbl -> - let [ar,sr,dr] = map (amodeToStix target) res + let + a2stix = amodeToStix target + data_hs = dataHS target + + ar = a2stix car + sr = a2stix csr + dr = a2stix cdr + len = case str of (CString s) -> _LENGTH_ s (CLit (MachStr s)) -> _LENGTH_ s @@ -240,13 +318,13 @@ gmpString2Integer target res [liveness, str] = save = StAssign PtrKind safeHp oldHp result = StIndex IntKind stgHpLim (StInt (toInteger (-mpIntSize))) set_str = StCall SLIT("mpz_init_set_str") IntKind - [result, amodeToStix target str, StInt 10] + [result, a2stix str, StInt 10] test = StPrim IntEqOp [set_str, StInt 0] cjmp = StCondJump ulbl test abort = StCall SLIT("abort") VoidKind [] join = StLabel ulbl restore = StAssign PtrKind stgHp safeHp - (a1,a2,a3) = fromStruct target result (ar,sr,dr) + (a1,a2,a3) = fromStruct data_hs result (ar,sr,dr) in macroCode target HEAP_CHK [liveness, mkIntCLit space, mkIntCLit_0] `thenSUs` \ heap_chk -> @@ -259,16 +337,28 @@ mkIntCLit_0 = mkIntCLit 0 -- out here to avoid CAF (sigh) encodeFloatingKind :: PrimKind -> Target - -> [CAddrMode] -- result - -> [CAddrMode] -- heap pointer for result, integer argument (3 parts), exponent + -> CAddrMode -- result + -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode) + -- heap pointer for result, integer argument (3 parts), exponent -> SUniqSM StixTreeList -encodeFloatingKind pk target [res] args = - let result = amodeToStix target res - [hp, aa,sa,da, expon] = map (amodeToStix target) args - pk' = if sizeof target FloatKind == sizeof target DoubleKind then DoubleKind +encodeFloatingKind pk target_STRICT res args@(chp, caa,csa,cda, cexpon) = + let + a2stix = amodeToStix target + size_of = sizeof target + data_hs = dataHS target + + result = a2stix res + hp = a2stix chp + aa = a2stix caa + sa = a2stix csa + da = a2stix cda + expon = a2stix cexpon + + pk' = if size_of FloatKind == size_of DoubleKind + then DoubleKind else pk - (a1,a2,a3) = toStruct target hp (aa,sa,da) + (a1,a2,a3) = toStruct data_hs hp (aa,sa,da) fn = case pk' of FloatKind -> SLIT("__encodeFloat") DoubleKind -> SLIT("__encodeDouble") @@ -281,14 +371,27 @@ encodeFloatingKind pk target [res] args = decodeFloatingKind :: PrimKind -> Target - -> [CAddrMode] -- exponent result, integer result (3 parts) - -> [CAddrMode] -- heap pointer for exponent, floating argument + -> (CAddrMode, CAddrMode, CAddrMode, CAddrMode) + -- exponent result, integer result (3 parts) + -> (CAddrMode, CAddrMode) + -- heap pointer for exponent, floating argument -> SUniqSM StixTreeList -decodeFloatingKind pk target res args = - let [exponr,ar,sr,dr] = map (amodeToStix target) res - [hp, arg] = map (amodeToStix target) args - pk' = if sizeof target FloatKind == sizeof target DoubleKind then DoubleKind +decodeFloatingKind pk target_STRICT res@(cexponr,car,csr,cdr) args@(chp, carg) = + let + a2stix = amodeToStix target + size_of = sizeof target + data_hs = dataHS target + + exponr = a2stix cexponr + ar = a2stix car + sr = a2stix csr + dr = a2stix cdr + hp = a2stix chp + arg = a2stix carg + + pk' = if size_of FloatKind == size_of DoubleKind + then DoubleKind else pk setup = StAssign PtrKind mpData_mantissa (StIndex IntKind hp (StInt 1)) fn = case pk' of @@ -296,7 +399,7 @@ decodeFloatingKind pk target res args = DoubleKind -> SLIT("__decodeDouble") _ -> panic "decodeFloatingKind" decode = StCall fn VoidKind [mantissa, hp, arg] - (a1,a2,a3) = fromStruct target mantissa (ar,sr,dr) + (a1,a2,a3) = fromStruct data_hs mantissa (ar,sr,dr) a4 = StAssign IntKind exponr (StInd IntKind hp) in returnSUs (\xs -> setup : decode : a1 : a2 : a3 : a4 : xs) @@ -317,18 +420,18 @@ mpSize base = StInd IntKind (StIndex IntKind base (StInt 1)) mpData base = StInd PtrKind (StIndex IntKind base (StInt 2)) mpSpace - :: Target + :: StixTree -- dataHs from Target -> Int -- gmp structures needed -> Int -- number of results -> [StixTree] -- sizes to add for estimating result size -> StixTree -- total space -mpSpace target gmp res sizes = +mpSpace data_hs gmp res sizes = foldr sum (StPrim IntAddOp [fixed, hdrs]) sizes where sum x y = StPrim IntAddOp [StPrim IntAbsOp [x], y] fixed = StInt (toInteger (17 * res + gmp * mpIntSize)) - hdrs = StPrim IntMulOp [dataHS target, StInt (toInteger res)] + hdrs = StPrim IntMulOp [data_hs, StInt (toInteger res)] \end{code} @@ -338,39 +441,36 @@ HpLim are our temporaries.) Note that you must have performed a heap check which includes the space needed for these temporaries before you use them. \begin{code} - mpStruct :: Int -> StixTree mpStruct n = StIndex IntKind stgHpLim (StInt (toInteger (-(n * mpIntSize)))) toStruct - :: Target + :: StixTree -- dataHS, from Target -> StixTree -> (StixTree, StixTree, StixTree) -> (StixTree, StixTree, StixTree) -toStruct target str (alloc,size,arr) = +toStruct data_hs str (alloc,size,arr) = let f1 = StAssign IntKind (mpAlloc str) alloc f2 = StAssign IntKind (mpSize str) size - f3 = StAssign PtrKind (mpData str) (StIndex PtrKind arr (dataHS target)) + f3 = StAssign PtrKind (mpData str) (StIndex PtrKind arr data_hs) in (f1, f2, f3) fromStruct - :: Target + :: StixTree -- dataHS, from Target -> StixTree -> (StixTree, StixTree, StixTree) -> (StixTree, StixTree, StixTree) -fromStruct target str (alloc,size,arr) = +fromStruct data_hs str (alloc,size,arr) = let e1 = StAssign IntKind alloc (mpAlloc str) e2 = StAssign IntKind size (mpSize str) e3 = StAssign PtrKind arr (StIndex PtrKind (mpData str) - (StPrim IntNegOp [dataHS target])) + (StPrim IntNegOp [data_hs])) in (e1, e2, e3) - - \end{code} diff --git a/ghc/compiler/nativeGen/StixMacro.hi b/ghc/compiler/nativeGen/StixMacro.hi index aa0f0ceea7..dba792dbe0 100644 --- a/ghc/compiler/nativeGen/StixMacro.hi +++ b/ghc/compiler/nativeGen/StixMacro.hi @@ -4,29 +4,24 @@ import AbsCSyn(AbstractC, CAddrMode, CExprMacro, CStmtMacro, MagicId, RegRelativ import BasicLit(BasicLit) import CLabelInfo(CLabel) import CharSeq(CSeq) -import CmdLineOpts(GlobalSwitch, SwitchResult) import CostCentre(CostCentre) import HeapOffs(HeapOffset) import MachDesc(RegLoc, Target) import PreludePS(_PackedString) import PreludeRatio(Ratio(..)) -import Pretty(PprStyle) import PrimKind(PrimKind) import PrimOps(PrimOp) import SMRep(SMRep) import SplitUniq(SplitUniqSupply) import Stix(CodeSegment, StixReg, StixTree) import Unique(Unique) -data CAddrMode {-# GHC_PRAGMA CVal RegRelative PrimKind | CAddr RegRelative | CReg MagicId | CTableEntry CAddrMode CAddrMode PrimKind | CTemp Unique PrimKind | CLbl CLabel PrimKind | CUnVecLbl CLabel CLabel | CCharLike CAddrMode | CIntLike CAddrMode | CString _PackedString | CLit BasicLit | CLitLit _PackedString PrimKind | COffset HeapOffset | CCode AbstractC | CLabelledCode CLabel AbstractC | CJoinPoint Int Int | CMacroExpr PrimKind CExprMacro [CAddrMode] | CCostCentre CostCentre Bool #-} -data CExprMacro {-# GHC_PRAGMA INFO_PTR | ENTRY_CODE | INFO_TAG | EVAL_TAG #-} -data CStmtMacro {-# GHC_PRAGMA ARGS_CHK_A_LOAD_NODE | ARGS_CHK_A | ARGS_CHK_B_LOAD_NODE | ARGS_CHK_B | HEAP_CHK | STK_CHK | UPD_CAF | UPD_IND | UPD_INPLACE_NOPTRS | UPD_INPLACE_PTRS | UPD_BH_UPDATABLE | UPD_BH_SINGLE_ENTRY | PUSH_STD_UPD_FRAME | POP_STD_UPD_FRAME | SET_ARITY | CHK_ARITY | SET_TAG #-} -data Target {-# GHC_PRAGMA Target (GlobalSwitch -> SwitchResult) Int (SMRep -> Int) (MagicId -> RegLoc) (StixTree -> StixTree) (PrimKind -> Int) ([MagicId] -> [StixTree]) ([MagicId] -> [StixTree]) (HeapOffset -> Int) (CAddrMode -> StixTree) (CAddrMode -> StixTree) Int Int StixTree StixTree ([CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) Bool ([Char] -> [Char]) #-} -data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-} -data StixTree {-# GHC_PRAGMA StSegment CodeSegment | StInt Integer | StDouble (Ratio Integer) | StString _PackedString | StLitLbl CSeq | StLitLit _PackedString | StCLbl CLabel | StReg StixReg | StIndex PrimKind StixTree StixTree | StInd PrimKind StixTree | StAssign PrimKind StixTree StixTree | StLabel CLabel | StFunBegin CLabel | StFunEnd CLabel | StJump StixTree | StFallThrough CLabel | StCondJump CLabel StixTree | StData PrimKind [StixTree] | StPrim PrimOp [StixTree] | StCall _PackedString PrimKind [StixTree] | StComment _PackedString #-} -doHeapCheck :: Target -> StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree] - {-# GHC_PRAGMA _A_ 5 _U_ 022012 _N_ _S_ "ALLAU(ALA)" {_A_ 3 _U_ 2212 _N_ _N_ _N_ _N_} _N_ _N_ #-} +data CAddrMode +data CExprMacro +data CStmtMacro +data Target +data SplitUniqSupply +data StixTree +doHeapCheck :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree] genMacroCode :: Target -> CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree] - {-# GHC_PRAGMA _A_ 3 _U_ 21122 _N_ _S_ "LEL" _N_ _N_ #-} smStablePtrTable :: StixTree - {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} diff --git a/ghc/compiler/nativeGen/StixMacro.lhs b/ghc/compiler/nativeGen/StixMacro.lhs index d49158bd6e..6f3e8c796b 100644 --- a/ghc/compiler/nativeGen/StixMacro.lhs +++ b/ghc/compiler/nativeGen/StixMacro.lhs @@ -35,15 +35,26 @@ closure address. mkIntCLit_0 = mkIntCLit 0 -- out here to avoid CAF (sigh) mkIntCLit_3 = mkIntCLit 3 +-- hacking with Uncle Will: +#define target_STRICT target@(Target _ _ _ _ _ _ _ _) + genMacroCode :: Target -> CStmtMacro -- statement macro -> [CAddrMode] -- args -> SUniqSM StixTreeList -genMacroCode target ARGS_CHK_A_LOAD_NODE args = +genMacroCode target_STRICT macro args + = genmacro macro args + where + a2stix = amodeToStix target + stg_reg = stgReg target + + -- real thing: here we go ----------------------- + + genmacro ARGS_CHK_A_LOAD_NODE args = getUniqLabelNCG `thenSUs` \ ulbl -> - let [words, lbl] = map (amodeToStix target) args + let [words, lbl] = map a2stix args temp = StIndex PtrKind stgSpA words test = StPrim AddrGeOp [stgSuA, temp] cjmp = StCondJump ulbl test @@ -52,9 +63,9 @@ genMacroCode target ARGS_CHK_A_LOAD_NODE args = in returnSUs (\xs -> cjmp : assign : updatePAP : join : xs) -genMacroCode target ARGS_CHK_A [words] = + genmacro ARGS_CHK_A [words] = getUniqLabelNCG `thenSUs` \ ulbl -> - let temp = StIndex PtrKind stgSpA (amodeToStix target words) + let temp = StIndex PtrKind stgSpA (a2stix words) test = StPrim AddrGeOp [stgSuA, temp] cjmp = StCondJump ulbl test join = StLabel ulbl @@ -71,9 +82,9 @@ directions are swapped relative to the A stack. \begin{code} -genMacroCode target ARGS_CHK_B_LOAD_NODE args = + genmacro ARGS_CHK_B_LOAD_NODE args = getUniqLabelNCG `thenSUs` \ ulbl -> - let [words, lbl] = map (amodeToStix target) args + let [words, lbl] = map a2stix args temp = StIndex PtrKind stgSuB (StPrim IntNegOp [words]) test = StPrim AddrGeOp [stgSpB, temp] cjmp = StCondJump ulbl test @@ -82,9 +93,9 @@ genMacroCode target ARGS_CHK_B_LOAD_NODE args = in returnSUs (\xs -> cjmp : assign : updatePAP : join : xs) -genMacroCode target ARGS_CHK_B [words] = + genmacro ARGS_CHK_B [words] = getUniqLabelNCG `thenSUs` \ ulbl -> - let temp = StIndex PtrKind stgSuB (StPrim IntNegOp [amodeToStix target words]) + let temp = StIndex PtrKind stgSuB (StPrim IntNegOp [a2stix words]) test = StPrim AddrGeOp [stgSpB, temp] cjmp = StCondJump ulbl test join = StLabel ulbl @@ -103,10 +114,10 @@ primOps, this is just a wrapper. \begin{code} -genMacroCode target HEAP_CHK args = - let [liveness,words,reenter] = map (amodeToStix target) args + genmacro HEAP_CHK args = + let [liveness,words,reenter] = map a2stix args in - doHeapCheck target liveness words reenter + doHeapCheck {-UNUSED NOW:target-} liveness words reenter \end{code} @@ -118,11 +129,11 @@ so we don't have to @callWrapper@ it. \begin{code} -genMacroCode target STK_CHK [liveness, aWords, bWords, spa, spb, prim, reenter] = + genmacro STK_CHK [liveness, aWords, bWords, spa, spb, prim, reenter] = {- Need to check to see if we are compiling with stack checks getUniqLabelNCG `thenSUs` \ ulbl -> let words = StPrim IntNegOp - [StPrim IntAddOp [amodeToStix target aWords, amodeToStix target bWords]] + [StPrim IntAddOp [a2stix aWords, a2stix bWords]] temp = StIndex PtrKind stgSpA words test = StPrim AddrGtOp [temp, stgSpB] cjmp = StCondJump ulbl test @@ -139,8 +150,8 @@ and putting the new CAF on a linked list for the storage manager. \begin{code} -genMacroCode target UPD_CAF args = - let [cafptr,bhptr] = map (amodeToStix target) args + genmacro UPD_CAF args = + let [cafptr,bhptr] = map a2stix args w0 = StInd PtrKind cafptr w1 = StInd PtrKind (StIndex PtrKind cafptr (StInt 1)) w2 = StInd PtrKind (StIndex PtrKind cafptr (StInt 2)) @@ -159,9 +170,9 @@ if we update an old generation object. \begin{code} -genMacroCode target UPD_IND args = + genmacro UPD_IND args = getUniqLabelNCG `thenSUs` \ ulbl -> - let [updptr, heapptr] = map (amodeToStix target) args + let [updptr, heapptr] = map a2stix args test = StPrim AddrGtOp [updptr, smOldLim] cjmp = StCondJump ulbl test updRoots = StAssign PtrKind smOldMutables updptr @@ -180,7 +191,7 @@ genMacroCode target UPD_IND args = \begin{code} -genMacroCode target UPD_INPLACE_NOPTRS args = returnSUs id + genmacro UPD_INPLACE_NOPTRS args = returnSUs id \end{code} @@ -190,7 +201,7 @@ if we update an old generation object. \begin{code} -genMacroCode target UPD_INPLACE_PTRS [liveness] = + genmacro UPD_INPLACE_PTRS [liveness] = getUniqLabelNCG `thenSUs` \ ulbl -> let cjmp = StCondJump ulbl testOldLim testOldLim = StPrim AddrGtOp [stgNode, smOldLim] @@ -204,7 +215,7 @@ genMacroCode target UPD_INPLACE_PTRS [liveness] = updOldMutables = StAssign PtrKind smOldMutables stgNode updUpdReg = StAssign PtrKind stgNode hpBack2 in - genMacroCode target HEAP_CHK [liveness, mkIntCLit_3, mkIntCLit_0] + genmacro HEAP_CHK [liveness, mkIntCLit_3, mkIntCLit_0] `thenSUs` \ heap_chk -> returnSUs (\xs -> (cjmp : heap_chk (updUpd0 : updUpd1 : updUpd2 : @@ -218,11 +229,11 @@ to handle @UPD_BH_SINGLE_ENTRY@ in all cases. \begin{code} -genMacroCode target UPD_BH_UPDATABLE args = returnSUs id + genmacro UPD_BH_UPDATABLE args = returnSUs id -genMacroCode target UPD_BH_SINGLE_ENTRY [arg] = + genmacro UPD_BH_SINGLE_ENTRY [arg] = let - update = StAssign PtrKind (StInd PtrKind (amodeToStix target arg)) bh_info + update = StAssign PtrKind (StInd PtrKind (a2stix arg)) bh_info in returnSUs (\xs -> update : xs) @@ -233,8 +244,8 @@ registers to the current Sp[AB] locations. \begin{code} -genMacroCode target PUSH_STD_UPD_FRAME args = - let [bhptr, aWords, bWords] = map (amodeToStix target) args + genmacro PUSH_STD_UPD_FRAME args = + let [bhptr, aWords, bWords] = map a2stix args frame n = StInd PtrKind (StIndex PtrKind stgSpB (StPrim IntAddOp [bWords, StInt (toInteger (sTD_UF_SIZE - n))])) @@ -258,7 +269,7 @@ Pop a standard update frame. \begin{code} -genMacroCode target POP_STD_UPD_FRAME args = + genmacro POP_STD_UPD_FRAME args = let frame n = StInd PtrKind (StIndex PtrKind stgSpB (StInt (toInteger (-n)))) grabRet = StAssign PtrKind stgRetReg (frame uF_RET) @@ -276,7 +287,7 @@ genMacroCode target POP_STD_UPD_FRAME args = \begin{code} {- UNUSED: -genMacroCode target PUSH_CON_UPD_FRAME args = + genmacro PUSH_CON_UPD_FRAME args = panic "genMacroCode:PUSH_CON_UPD_FRAME" -} \end{code} @@ -285,8 +296,8 @@ The @SET_ARITY@ and @CHK_ARITY@ macros are disabled for ``normal'' compilation. \begin{code} -genMacroCode target SET_ARITY args = returnSUs id -genMacroCode target CHK_ARITY args = returnSUs id + genmacro SET_ARITY args = returnSUs id + genmacro CHK_ARITY args = returnSUs id \end{code} @@ -294,10 +305,10 @@ This one only applies if we have a machine register devoted to TagReg. \begin{code} -genMacroCode target SET_TAG [tag] = - let set_tag = StAssign IntKind stgTagReg (amodeToStix target tag) + genmacro SET_TAG [tag] = + let set_tag = StAssign IntKind stgTagReg (a2stix tag) in - case stgReg target TagReg of + case stg_reg TagReg of Always _ -> returnSUs id Save _ -> returnSUs (\xs -> set_tag : xs) @@ -309,13 +320,13 @@ of StixOp. \begin{code} doHeapCheck - :: Target - -> StixTree -- liveness + :: {- unused now: Target + -> -}StixTree -- liveness -> StixTree -- words needed -> StixTree -- always reenter node? (boolean) -> SUniqSM StixTreeList -doHeapCheck target liveness words reenter = +doHeapCheck {-target:unused now-} liveness words reenter = getUniqLabelNCG `thenSUs` \ ulbl -> let newHp = StIndex PtrKind stgHp words assign = StAssign PtrKind stgHp newHp diff --git a/ghc/compiler/nativeGen/StixPrim.hi b/ghc/compiler/nativeGen/StixPrim.hi index 2f54eb0d7c..a14b709ede 100644 --- a/ghc/compiler/nativeGen/StixPrim.hi +++ b/ghc/compiler/nativeGen/StixPrim.hi @@ -4,13 +4,11 @@ import AbsCSyn(AbstractC, CAddrMode, CExprMacro, CStmtMacro, MagicId, RegRelativ import BasicLit(BasicLit) import CLabelInfo(CLabel) import CharSeq(CSeq) -import CmdLineOpts(GlobalSwitch, SwitchResult) import CostCentre(CostCentre) import HeapOffs(HeapOffset) import MachDesc(RegLoc, Target) import PreludePS(_PackedString) import PreludeRatio(Ratio(..)) -import Pretty(PprStyle) import PrimKind(PrimKind) import PrimOps(PrimOp) import SMRep(SMRep) @@ -18,16 +16,12 @@ import SplitUniq(SplitUniqSupply) import Stix(CodeSegment, StixReg, StixTree) import UniType(UniType) import Unique(Unique) -data CAddrMode {-# GHC_PRAGMA CVal RegRelative PrimKind | CAddr RegRelative | CReg MagicId | CTableEntry CAddrMode CAddrMode PrimKind | CTemp Unique PrimKind | CLbl CLabel PrimKind | CUnVecLbl CLabel CLabel | CCharLike CAddrMode | CIntLike CAddrMode | CString _PackedString | CLit BasicLit | CLitLit _PackedString PrimKind | COffset HeapOffset | CCode AbstractC | CLabelledCode CLabel AbstractC | CJoinPoint Int Int | CMacroExpr PrimKind CExprMacro [CAddrMode] | CCostCentre CostCentre Bool #-} -data Target {-# GHC_PRAGMA Target (GlobalSwitch -> SwitchResult) Int (SMRep -> Int) (MagicId -> RegLoc) (StixTree -> StixTree) (PrimKind -> Int) ([MagicId] -> [StixTree]) ([MagicId] -> [StixTree]) (HeapOffset -> Int) (CAddrMode -> StixTree) (CAddrMode -> StixTree) Int Int StixTree StixTree ([CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) Bool ([Char] -> [Char]) #-} -data PrimOp - {-# GHC_PRAGMA 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 | OrdOp | ChrOp | IntAddOp | IntSubOp | IntMulOp | IntQuotOp | IntDivOp | IntRemOp | IntNegOp | IntAbsOp | AndOp | OrOp | NotOp | SllOp | SraOp | SrlOp | ISllOp | ISraOp | ISrlOp | Int2WordOp | Word2IntOp | Int2AddrOp | Addr2IntOp | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp | Float2IntOp | Int2FloatOp | FloatExpOp | FloatLogOp | FloatSqrtOp | FloatSinOp | FloatCosOp | FloatTanOp | FloatAsinOp | FloatAcosOp | FloatAtanOp | FloatSinhOp | FloatCoshOp | FloatTanhOp | FloatPowerOp | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp | Double2IntOp | Int2DoubleOp | Double2FloatOp | Float2DoubleOp | DoubleExpOp | DoubleLogOp | DoubleSqrtOp | DoubleSinOp | DoubleCosOp | DoubleTanOp | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp | DoublePowerOp | IntegerAddOp | IntegerSubOp | IntegerMulOp | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp | IntegerCmpOp | Integer2IntOp | Int2IntegerOp | Word2IntegerOp | Addr2IntegerOp | FloatEncodeOp | FloatDecodeOp | DoubleEncodeOp | DoubleDecodeOp | NewArrayOp | NewByteArrayOp PrimKind | SameMutableArrayOp | SameMutableByteArrayOp | ReadArrayOp | WriteArrayOp | IndexArrayOp | ReadByteArrayOp PrimKind | WriteByteArrayOp PrimKind | IndexByteArrayOp PrimKind | IndexOffAddrOp PrimKind | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp | NewSynchVarOp | TakeMVarOp | PutMVarOp | ReadIVarOp | WriteIVarOp | MakeStablePtrOp | DeRefStablePtrOp | CCallOp _PackedString Bool Bool [UniType] UniType | ErrorIOPrimOp | ReallyUnsafePtrEqualityOp | SeqOp | ParOp | ForkOp | DelayOp | WaitOp #-} -data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-} -data StixTree {-# GHC_PRAGMA StSegment CodeSegment | StInt Integer | StDouble (Ratio Integer) | StString _PackedString | StLitLbl CSeq | StLitLit _PackedString | StCLbl CLabel | StReg StixReg | StIndex PrimKind StixTree StixTree | StInd PrimKind StixTree | StAssign PrimKind StixTree StixTree | StLabel CLabel | StFunBegin CLabel | StFunEnd CLabel | StJump StixTree | StFallThrough CLabel | StCondJump CLabel StixTree | StData PrimKind [StixTree] | StPrim PrimOp [StixTree] | StCall _PackedString PrimKind [StixTree] | StComment _PackedString #-} +data CAddrMode +data Target +data PrimOp +data SplitUniqSupply +data StixTree amodeCode :: Target -> CAddrMode -> StixTree - {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-} amodeCode' :: Target -> CAddrMode -> StixTree - {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-} genPrimCode :: Target -> [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree] - {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _S_ "LSSL" _N_ _N_ #-} diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs index 977d9ef840..40c1a3a878 100644 --- a/ghc/compiler/nativeGen/StixPrim.lhs +++ b/ghc/compiler/nativeGen/StixPrim.lhs @@ -62,41 +62,22 @@ btw Why not let programmer use casm to provide assembly code instead of C code? ADR \begin{code} - -genPrimCode target lhs (CCallOp fn is_asm may_gc arg_tys result_ty) rhs - | is_asm = error "ERROR: Native code generator can't handle casm" - | otherwise = - case lhs of - [] -> returnSUs (\xs -> (StCall fn VoidKind args) : xs) - [lhs] -> - let lhs' = amodeToStix target lhs - pk = if isFloatingKind (getAmodeKind lhs) then DoubleKind else IntKind - call = StAssign pk lhs' (StCall fn pk args) - in - returnSUs (\xs -> call : xs) - where - args = map amodeCodeForCCall rhs - amodeCodeForCCall x = - let base = amodeToStix' target x - in - case getAmodeKind x of - ArrayKind -> StIndex PtrKind base (mutHS target) - ByteArrayKind -> StIndex IntKind base (dataHS target) - MallocPtrKind -> error "ERROR: native-code generator can't handle Malloc Ptrs (yet): use -fvia-C!" - _ -> base - -\end{code} - -The @ErrorIO@ primitive is actually a bit weird...assign a new value to the root -closure, flush stdout and stderr, and jump to the @ErrorIO_innards@. - -\begin{code} - -genPrimCode target [] ErrorIOPrimOp [rhs] = - let changeTop = StAssign PtrKind topClosure (amodeToStix target rhs) - in - returnSUs (\xs -> changeTop : flushStdout : flushStderr : errorIO : xs) - +-- hacking with Uncle Will: +#define target_STRICT target@(Target _ _ _ _ _ _ _ _) + +genPrimCode target_STRICT res op args + = genprim res op args + where + a2stix = amodeToStix target + a2stix' = amodeToStix' target + mut_hs = mutHS target + data_hs = dataHS target + heap_chkr = heapCheck target + size_of = sizeof target + fixed_hs = fixedHeaderSize target + var_hs = varHeaderSize target + + --- real code will follow... ------------- \end{code} The (MP) integer operations are a true nightmare. Since we don't have a @@ -105,90 +86,107 @@ we use the space just below HpLim for the @MP_INT@ structures, and modify our heap check accordingly. \begin{code} - -genPrimCode target res IntegerAddOp args = - gmpTake2Return1 target res SLIT("mpz_add") args -genPrimCode target res IntegerSubOp args = - gmpTake2Return1 target res SLIT("mpz_sub") args -genPrimCode target res IntegerMulOp args = - gmpTake2Return1 target res SLIT("mpz_mul") args - -genPrimCode target res IntegerNegOp arg = - gmpTake1Return1 target res SLIT("mpz_neg") arg - -genPrimCode target res IntegerQuotRemOp arg = - gmpTake2Return2 target res SLIT("mpz_divmod") arg -genPrimCode target res IntegerDivModOp arg = - gmpTake2Return2 target res SLIT("mpz_targetivmod") arg - + -- NB: ordering of clauses somewhere driven by + -- the desire to getting sane patt-matching behavior + + genprim res@[ar1,sr1,dr1, ar2,sr2,dr2] + IntegerQuotRemOp + args@[liveness, aa1,sa1,da1, aa2,sa2,da2] = + gmpTake2Return2 target (ar1,sr1,dr1, ar2,sr2,dr2) SLIT("mpz_divmod") (liveness, aa1,sa1,da1, aa2,sa2,da2) + + genprim res@[ar1,sr1,dr1, ar2,sr2,dr2] + IntegerDivModOp + args@[liveness, aa1,sa1,da1, aa2,sa2,da2] = + gmpTake2Return2 target (ar1,sr1,dr1, ar2,sr2,dr2) SLIT("mpz_targetivmod") (liveness, aa1,sa1,da1, aa2,sa2,da2) + + genprim res@[ar,sr,dr] IntegerAddOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2] = + gmpTake2Return1 target (ar,sr,dr) SLIT("mpz_add") (liveness, aa1,sa1,da1, aa2,sa2,da2) + genprim res@[ar,sr,dr] IntegerSubOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2] = + gmpTake2Return1 target (ar,sr,dr) SLIT("mpz_sub") (liveness, aa1,sa1,da1, aa2,sa2,da2) + genprim res@[ar,sr,dr] IntegerMulOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2] = + gmpTake2Return1 target (ar,sr,dr) SLIT("mpz_mul") (liveness, aa1,sa1,da1, aa2,sa2,da2) + + genprim res@[ar,sr,dr] IntegerNegOp arg@[liveness,aa,sa,da] = + gmpTake1Return1 target (ar,sr,dr) SLIT("mpz_neg") (liveness,aa,sa,da) \end{code} Since we are using the heap for intermediate @MP_INT@ structs, integer comparison {\em does} require a heap check in the native code implementation. \begin{code} + genprim res@[exponr,ar,sr,dr] FloatDecodeOp args@[hp, arg] = + decodeFloatingKind FloatKind target (exponr,ar,sr,dr) (hp, arg) + + genprim res@[exponr,ar,sr,dr] DoubleDecodeOp args@[hp, arg] = + decodeFloatingKind DoubleKind target (exponr,ar,sr,dr) (hp, arg) -genPrimCode target [res] IntegerCmpOp args = gmpCompare target res args + genprim res@[ar,sr,dr] Int2IntegerOp args@[hp, n] + = gmpInt2Integer target (ar,sr,dr) (hp, n) -genPrimCode target [res] Integer2IntOp arg = gmpInteger2Int target res arg + genprim res@[ar,sr,dr] Addr2IntegerOp args@[liveness,str] + = gmpString2Integer target (ar,sr,dr) (liveness,str) -genPrimCode target res Int2IntegerOp args = gmpInt2Integer target res args + genprim [res] IntegerCmpOp args@[hp, aa1,sa1,da1, aa2,sa2,da2] + = gmpCompare target res (hp, aa1,sa1,da1, aa2,sa2,da2) -genPrimCode target res Word2IntegerOp args = panic "genPrimCode:Word2IntegerOp" + genprim [res] Integer2IntOp arg@[hp, aa,sa,da] + = gmpInteger2Int target res (hp, aa,sa,da) -genPrimCode target res Addr2IntegerOp args = gmpString2Integer target res args + genprim [res] FloatEncodeOp args@[hp, aa,sa,da, expon] = + encodeFloatingKind FloatKind target res (hp, aa,sa,da, expon) -genPrimCode target res FloatEncodeOp args = - encodeFloatingKind FloatKind target res args + genprim [res] DoubleEncodeOp args@[hp, aa,sa,da, expon] = + encodeFloatingKind DoubleKind target res (hp, aa,sa,da, expon) -genPrimCode target res DoubleEncodeOp args = - encodeFloatingKind DoubleKind target res args + genprim [res] Int2AddrOp [arg] = + simpleCoercion AddrKind res arg -genPrimCode target res FloatDecodeOp args = - decodeFloatingKind FloatKind target res args + genprim [res] Addr2IntOp [arg] = + simpleCoercion IntKind res arg -genPrimCode target res DoubleDecodeOp args = - decodeFloatingKind DoubleKind target res args + genprim [res] Int2WordOp [arg] = + simpleCoercion IntKind{-WordKind?-} res arg -genPrimCode target res Int2AddrOp arg = - simpleCoercion target AddrKind res arg + genprim [res] Word2IntOp [arg] = + simpleCoercion IntKind res arg + +\end{code} -genPrimCode target res Addr2IntOp arg = - simpleCoercion target IntKind res arg +The @ErrorIO@ primitive is actually a bit weird...assign a new value to the root +closure, flush stdout and stderr, and jump to the @ErrorIO_innards@. -genPrimCode target res Int2WordOp arg = - simpleCoercion target IntKind{-WordKind?-} res arg +\begin{code} -genPrimCode target res Word2IntOp arg = - simpleCoercion target IntKind res arg + genprim [] ErrorIOPrimOp [rhs] = + let changeTop = StAssign PtrKind topClosure (a2stix rhs) + in + returnSUs (\xs -> changeTop : flushStdout : flushStderr : errorIO : xs) \end{code} @newArray#@ ops allocate heap space. \begin{code} - -genPrimCode target [res] NewArrayOp args = - let [liveness, n, initial] = map (amodeToStix target) args - result = amodeToStix target res - space = StPrim IntAddOp [n, mutHS target] + genprim [res] NewArrayOp args = + let [liveness, n, initial] = map a2stix args + result = a2stix res + space = StPrim IntAddOp [n, mut_hs] loc = StIndex PtrKind stgHp (StPrim IntNegOp [StPrim IntSubOp [space, StInt 1]]) assign = StAssign PtrKind result loc initialise = StCall SLIT("newArrZh_init") VoidKind [result, n, initial] in - heapCheck target liveness space (StInt 0) - `thenSUs` \ heap_chk -> + heap_chkr liveness space (StInt 0) `thenSUs` \ heap_chk -> returnSUs (heap_chk . (\xs -> assign : initialise : xs)) -genPrimCode target [res] (NewByteArrayOp pk) args = - let [liveness, count] = map (amodeToStix target) args - result = amodeToStix target res - n = StPrim IntMulOp [count, StInt (toInteger (sizeof target pk))] - slop = StPrim IntAddOp [n, StInt (toInteger (sizeof target IntKind - 1))] - words = StPrim IntDivOp [slop, StInt (toInteger (sizeof target IntKind))] - space = StPrim IntAddOp [n, StPrim IntAddOp [words, dataHS target]] + genprim [res] (NewByteArrayOp pk) args = + let [liveness, count] = map a2stix args + result = a2stix res + n = StPrim IntMulOp [count, StInt (toInteger (size_of pk))] + slop = StPrim IntAddOp [n, StInt (toInteger (size_of IntKind - 1))] + words = StPrim IntQuotOp [slop, StInt (toInteger (size_of IntKind))] + space = StPrim IntAddOp [n, StPrim IntAddOp [words, data_hs]] loc = StIndex PtrKind stgHp (StPrim IntNegOp [StPrim IntSubOp [space, StInt 1]]) assign = StAssign PtrKind result loc @@ -196,24 +194,22 @@ genPrimCode target [res] (NewByteArrayOp pk) args = init2 = StAssign IntKind (StInd IntKind (StIndex IntKind loc - (StInt (toInteger (fixedHeaderSize target))))) + (StInt (toInteger fixed_hs)))) (StPrim IntAddOp [words, - StInt (toInteger (varHeaderSize target - (DataRep 0)))]) + StInt (toInteger (var_hs (DataRep 0)))]) in - heapCheck target liveness space (StInt 0) - `thenSUs` \ heap_chk -> + heap_chkr liveness space (StInt 0) `thenSUs` \ heap_chk -> returnSUs (heap_chk . (\xs -> assign : init1 : init2 : xs)) -genPrimCode target [res] SameMutableArrayOp args = - let compare = StPrim AddrEqOp (map (amodeToStix target) args) - assign = StAssign IntKind (amodeToStix target res) compare + genprim [res] SameMutableArrayOp args = + let compare = StPrim AddrEqOp (map a2stix args) + assign = StAssign IntKind (a2stix res) compare in returnSUs (\xs -> assign : xs) -genPrimCode target res SameMutableByteArrayOp args = - genPrimCode target res SameMutableArrayOp args + genprim res@[_] SameMutableByteArrayOp args = + genprim res SameMutableArrayOp args \end{code} @@ -223,17 +219,17 @@ the indirection (most likely, it's a VanillaReg). \begin{code} -genPrimCode target [lhs] UnsafeFreezeArrayOp [rhs] = - let lhs' = amodeToStix target lhs - rhs' = amodeToStix target rhs + genprim [lhs] UnsafeFreezeArrayOp [rhs] = + let lhs' = a2stix lhs + rhs' = a2stix rhs header = StInd PtrKind lhs' assign = StAssign PtrKind lhs' rhs' freeze = StAssign PtrKind header imMutArrayOfPtrs_info in returnSUs (\xs -> assign : freeze : xs) -genPrimCode target lhs UnsafeFreezeByteArrayOp rhs = - simpleCoercion target PtrKind lhs rhs + genprim [lhs] UnsafeFreezeByteArrayOp [rhs] = + simpleCoercion PtrKind lhs rhs \end{code} @@ -241,56 +237,57 @@ Most other array primitives translate to simple indexing. \begin{code} -genPrimCode target lhs IndexArrayOp args = - genPrimCode target lhs ReadArrayOp args + genprim lhs@[_] IndexArrayOp args = + genprim lhs ReadArrayOp args -genPrimCode target [lhs] ReadArrayOp [obj, ix] = - let lhs' = amodeToStix target lhs - obj' = amodeToStix target obj - ix' = amodeToStix target ix - base = StIndex IntKind obj' (mutHS target) + genprim [lhs] ReadArrayOp [obj, ix] = + let lhs' = a2stix lhs + obj' = a2stix obj + ix' = a2stix ix + base = StIndex IntKind obj' mut_hs assign = StAssign PtrKind lhs' (StInd PtrKind (StIndex PtrKind base ix')) in returnSUs (\xs -> assign : xs) -genPrimCode target [lhs] WriteArrayOp [obj, ix, v] = - let obj' = amodeToStix target obj - ix' = amodeToStix target ix - v' = amodeToStix target v - base = StIndex IntKind obj' (mutHS target) + genprim [lhs] WriteArrayOp [obj, ix, v] = + let obj' = a2stix obj + ix' = a2stix ix + v' = a2stix v + base = StIndex IntKind obj' mut_hs assign = StAssign PtrKind (StInd PtrKind (StIndex PtrKind base ix')) v' in returnSUs (\xs -> assign : xs) -genPrimCode target lhs (IndexByteArrayOp pk) args = - genPrimCode target lhs (ReadByteArrayOp pk) args + genprim lhs@[_] (IndexByteArrayOp pk) args = + genprim lhs (ReadByteArrayOp pk) args + +-- NB: indexing in "pk" units, *not* in bytes (WDP 95/09) -genPrimCode target [lhs] (ReadByteArrayOp pk) [obj, ix] = - let lhs' = amodeToStix target lhs - obj' = amodeToStix target obj - ix' = amodeToStix target ix - base = StIndex IntKind obj' (dataHS target) - assign = StAssign pk lhs' (StInd pk (StIndex CharKind base ix')) + genprim [lhs] (ReadByteArrayOp pk) [obj, ix] = + let lhs' = a2stix lhs + obj' = a2stix obj + ix' = a2stix ix + base = StIndex IntKind obj' data_hs + assign = StAssign pk lhs' (StInd pk (StIndex pk base ix')) in returnSUs (\xs -> assign : xs) -genPrimCode target [] (WriteByteArrayOp pk) [obj, ix, v] = - let obj' = amodeToStix target obj - ix' = amodeToStix target ix - v' = amodeToStix target v - base = StIndex IntKind obj' (dataHS target) - assign = StAssign pk (StInd pk (StIndex CharKind base ix')) v' + genprim [lhs] (IndexOffAddrOp pk) [obj, ix] = + let lhs' = a2stix lhs + obj' = a2stix obj + ix' = a2stix ix + assign = StAssign pk lhs' (StInd pk (StIndex pk obj' ix')) in returnSUs (\xs -> assign : xs) -genPrimCode target [lhs] (IndexOffAddrOp pk) [obj, ix] = - let lhs' = amodeToStix target lhs - obj' = amodeToStix target obj - ix' = amodeToStix target ix - assign = StAssign pk lhs' (StInd pk (StIndex CharKind obj' ix')) + genprim [] (WriteByteArrayOp pk) [obj, ix, v] = + let obj' = a2stix obj + ix' = a2stix ix + v' = a2stix v + base = StIndex IntKind obj' data_hs + assign = StAssign pk (StInd pk (StIndex pk base ix')) v' in returnSUs (\xs -> assign : xs) - \end{code} Stable pointer operations. @@ -299,10 +296,10 @@ First the easy one. \begin{code} -genPrimCode target [lhs] DeRefStablePtrOp [sp] = - let lhs' = amodeToStix target lhs + genprim [lhs] DeRefStablePtrOp [sp] = + let lhs' = a2stix lhs pk = getAmodeKind lhs - sp' = amodeToStix target sp + sp' = a2stix sp call = StCall SLIT("deRefStablePointer") pk [sp', smStablePtrTable] assign = StAssign pk lhs' call in @@ -354,7 +351,7 @@ Notes for ADR: --JSM \begin{pseudocode} -genPrimCode sty md [lhs] MakeStablePtrOp args = + genprim [lhs] MakeStablePtrOp args = let -- some useful abbreviations (I'm sure these must exist already) add = trPrim . IntAddOp @@ -412,26 +409,51 @@ genPrimCode sty md [lhs] MakeStablePtrOp args = (spt_EMPTY spt oklbl : (enlarge ++ (trLabel [oklbl] : allocate))) \end{pseudocode} +\begin{code} + genprim res Word2IntegerOp args = panic "genPrimCode:Word2IntegerOp" + + genprim lhs (CCallOp fn is_asm may_gc arg_tys result_ty) rhs + | is_asm = error "ERROR: Native code generator can't handle casm" + | otherwise = + case lhs of + [] -> returnSUs (\xs -> (StCall fn VoidKind args) : xs) + [lhs] -> + let lhs' = a2stix lhs + pk = if isFloatingKind (getAmodeKind lhs) then DoubleKind else IntKind + call = StAssign pk lhs' (StCall fn pk args) + in + returnSUs (\xs -> call : xs) + where + args = map amodeCodeForCCall rhs + amodeCodeForCCall x = + let base = a2stix' x + in + case getAmodeKind x of + ArrayKind -> StIndex PtrKind base mut_hs + ByteArrayKind -> StIndex IntKind base data_hs + MallocPtrKind -> error "ERROR: native-code generator can't handle Malloc Ptrs (yet): use -fvia-C!" + _ -> base +\end{code} Now the more mundane operations. \begin{code} - -genPrimCode target lhs op rhs = - let lhs' = map (amodeToStix target) lhs - rhs' = map (amodeToStix' target) rhs + genprim lhs op rhs = + let lhs' = map a2stix lhs + rhs' = map a2stix' rhs in - returnSUs (\ xs -> simplePrim target lhs' op rhs' : xs) - -simpleCoercion - :: Target - -> PrimKind - -> [CAddrMode] - -> [CAddrMode] - -> SUniqSM StixTreeList - -simpleCoercion target pk [lhs] [rhs] = - returnSUs (\xs -> StAssign pk (amodeToStix target lhs) (amodeToStix target rhs) : xs) + returnSUs (\ xs -> simplePrim lhs' op rhs' : xs) + + {- + simpleCoercion + :: Target + -> PrimKind + -> [CAddrMode] + -> [CAddrMode] + -> SUniqSM StixTreeList + -} + simpleCoercion pk lhs rhs = + returnSUs (\xs -> StAssign pk (a2stix lhs) (a2stix rhs) : xs) \end{code} @@ -440,30 +462,30 @@ can understand. Any primitives not handled here must be handled at the level of the specific code generator. \begin{code} - -simplePrim + {- + simplePrim :: Target -> [StixTree] -> PrimOp -> [StixTree] -> StixTree - + -} \end{code} Now look for something more conventional. \begin{code} -simplePrim target [lhs] op rest = StAssign pk lhs (StPrim op rest) + simplePrim [lhs] op rest = StAssign pk lhs (StPrim op rest) where pk = if isCompareOp op then IntKind else case getPrimOpResultInfo op of ReturnsPrim pk -> pk _ -> simplePrim_error op -simplePrim target _ op _ = simplePrim_error op + simplePrim _ op _ = simplePrim_error op -simplePrim_error op - = error ("ERROR: primitive operation `"++showPrimOp PprDebug op++"'cannot be handled\nby the native-code generator. Workaround: use -fvia-C.\n(Perhaps you should report it as a GHC bug, also.)\n") + simplePrim_error op + = error ("ERROR: primitive operation `"++showPrimOp PprDebug op++"'cannot be handled\nby the native-code generator. Workaround: use -fvia-C.\n(Perhaps you should report it as a GHC bug, also.)\n") \end{code} %--------------------------------------------------------------------- @@ -481,92 +503,102 @@ amodeCode, amodeCode' -> CAddrMode -> StixTree -amodeCode' target am@(CVal rr CharKind) +amodeCode'{-'-} target_STRICT am@(CVal rr CharKind) | mixedTypeLocn am = StPrim ChrOp [amodeToStix target am] | otherwise = amodeToStix target am amodeCode' target am = amodeToStix target am -amodeCode target am@(CVal rr CharKind) | mixedTypeLocn am = - StInd IntKind (amodeCode target (CAddr rr)) +amodeCode target_STRICT am + = acode am + where + -- grab "target" things: + hp_rel = hpRel target + char_like = charLikeClosureSize target + int_like = intLikeClosureSize target + a2stix = amodeToStix target + + -- real code: ---------------------------------- + acode am@(CVal rr CharKind) | mixedTypeLocn am = + StInd IntKind (acode (CAddr rr)) -amodeCode target (CVal rr pk) = StInd pk (amodeCode target (CAddr rr)) + acode (CVal rr pk) = StInd pk (acode (CAddr rr)) -amodeCode target (CAddr r@(SpARel spA off)) = - StIndex PtrKind stgSpA (StInt (toInteger (spARelToInt r))) + acode (CAddr r@(SpARel spA off)) = + StIndex PtrKind stgSpA (StInt (toInteger (spARelToInt r))) -amodeCode target (CAddr r@(SpBRel spB off)) = - StIndex IntKind stgSpB (StInt (toInteger (spBRelToInt r))) + acode (CAddr r@(SpBRel spB off)) = + StIndex IntKind stgSpB (StInt (toInteger (spBRelToInt r))) -amodeCode target (CAddr (HpRel hp off)) = - StIndex IntKind stgHp (StInt (toInteger (-(hpRel target (hp `subOff` off))))) + acode (CAddr (HpRel hp off)) = + StIndex IntKind stgHp (StInt (toInteger (-(hp_rel (hp `subOff` off))))) -amodeCode target (CAddr (NodeRel off)) = - StIndex IntKind stgNode (StInt (toInteger (hpRel target off))) + acode (CAddr (NodeRel off)) = + StIndex IntKind stgNode (StInt (toInteger (hp_rel off))) -amodeCode target (CReg magic) = StReg (StixMagicId magic) -amodeCode target (CTemp uniq pk) = StReg (StixTemp uniq pk) + acode (CReg magic) = StReg (StixMagicId magic) + acode (CTemp uniq pk) = StReg (StixTemp uniq pk) -amodeCode target (CLbl lbl _) = StCLbl lbl + acode (CLbl lbl _) = StCLbl lbl -amodeCode target (CUnVecLbl dir _) = StCLbl dir + acode (CUnVecLbl dir _) = StCLbl dir -amodeCode target (CTableEntry base off pk) = - StInd pk (StIndex pk (amodeCode target base) (amodeCode target off)) + acode (CTableEntry base off pk) = + StInd pk (StIndex pk (acode base) (acode off)) --- For CharLike and IntLike, we attempt some trivial constant-folding here. + -- For CharLike and IntLike, we attempt some trivial constant-folding here. -amodeCode target (CCharLike (CLit (MachChar c))) = - StLitLbl (uppBeside (uppPStr SLIT("CHARLIKE_closures+")) (uppInt off)) - where off = charLikeClosureSize target * ord c + acode (CCharLike (CLit (MachChar c))) = + StLitLbl (uppBeside (uppPStr SLIT("CHARLIKE_closures+")) (uppInt off)) + where off = char_like * ord c -amodeCode target (CCharLike x) = - StPrim IntAddOp [charLike, off] - where off = StPrim IntMulOp [amodeCode target x, - StInt (toInteger (charLikeClosureSize target))] + acode (CCharLike x) = + StPrim IntAddOp [charLike, off] + where off = StPrim IntMulOp [acode x, + StInt (toInteger (char_like))] -amodeCode target (CIntLike (CLit (MachInt i _))) = - StPrim IntAddOp [intLikePtr, StInt off] - where off = toInteger (intLikeClosureSize target) * i + acode (CIntLike (CLit (MachInt i _))) = + StPrim IntAddOp [intLikePtr, StInt off] + where off = toInteger int_like * i -amodeCode target (CIntLike x) = - StPrim IntAddOp [intLikePtr, off] - where off = StPrim IntMulOp [amodeCode target x, - StInt (toInteger (intLikeClosureSize target))] + acode (CIntLike x) = + StPrim IntAddOp [intLikePtr, off] + where off = StPrim IntMulOp [acode x, + StInt (toInteger int_like)] --- A CString is just a (CLit . MachStr) -amodeCode target (CString s) = StString s + -- A CString is just a (CLit . MachStr) + acode (CString s) = StString s -amodeCode target (CLit core) = case core of - (MachChar c) -> StInt (toInteger (ord c)) - (MachStr s) -> StString s - (MachAddr a) -> StInt a - (MachInt i _) -> StInt i - (MachLitLit s _) -> StLitLit s - (MachFloat d) -> StDouble d - (MachDouble d) -> StDouble d - _ -> panic "amodeCode:core literal" + acode (CLit core) = case core of + (MachChar c) -> StInt (toInteger (ord c)) + (MachStr s) -> StString s + (MachAddr a) -> StInt a + (MachInt i _) -> StInt i + (MachLitLit s _) -> StLitLit s + (MachFloat d) -> StDouble d + (MachDouble d) -> StDouble d + _ -> panic "amodeCode:core literal" --- A CLitLit is just a (CLit . MachLitLit) -amodeCode target (CLitLit s _) = StLitLit s + -- A CLitLit is just a (CLit . MachLitLit) + acode (CLitLit s _) = StLitLit s --- COffsets are in words, not bytes! -amodeCode target (COffset off) = StInt (toInteger (hpRel target off)) + -- COffsets are in words, not bytes! + acode (COffset off) = StInt (toInteger (hp_rel off)) -amodeCode target (CMacroExpr _ macro [arg]) = - case macro of - INFO_PTR -> StInd PtrKind (amodeToStix target arg) - ENTRY_CODE -> amodeToStix target arg - INFO_TAG -> tag - EVAL_TAG -> StPrim IntGeOp [tag, StInt 0] - where - tag = StInd IntKind (StIndex IntKind (amodeToStix target arg) (StInt (-2))) - -- That ``-2'' really bothers me. (JSM) + acode (CMacroExpr _ macro [arg]) = + case macro of + INFO_PTR -> StInd PtrKind (a2stix arg) + ENTRY_CODE -> a2stix arg + INFO_TAG -> tag + EVAL_TAG -> StPrim IntGeOp [tag, StInt 0] + where + tag = StInd IntKind (StIndex IntKind (a2stix arg) (StInt (-2))) + -- That ``-2'' really bothers me. (JSM) -amodeCode target (CCostCentre cc print_as_string) - = if noCostCentreAttached cc - then StComment SLIT("") -- sigh - else panic "amodeCode:CCostCentre" + acode (CCostCentre cc print_as_string) + = if noCostCentreAttached cc + then StComment SLIT("") -- sigh + else panic "amodeCode:CCostCentre" \end{code} Sizes of the CharLike and IntLike closures that are arranged as arrays in the |