rET_SMALL, rET_BIG,
rET_VEC_SMALL, rET_VEC_BIG
)
-import Constants ( mIN_UPD_SIZE )
+import Constants ( mIN_UPD_SIZE, wORD_SIZE )
import CLabel ( CLabel, mkReturnInfoLabel, mkReturnPtLabel,
mkClosureTblLabel, mkClosureLabel,
labelDynamic, mkSplitMarkerLabel )
staticClosureNeedsLink
)
import Literal ( Literal(..), word2IntLit )
-import Maybes ( maybeToBool )
+import Maybes ( Maybe012(..), maybeToBool )
import StgSyn ( StgOp(..) )
-import PrimOp ( primOpNeedsWrapper, PrimOp(..) )
+import MachOp ( MachOp(..), resultRepsOfMachOp )
import PrimRep ( isFloatingRep, PrimRep(..) )
import StixInfo ( genCodeInfoTable, genBitmapInfoTable,
livenessIsSmall, bitmapToIntegers )
import StixMacro ( macroCode, checkCode )
-import StixPrim ( primCode, foreignCallCode, amodeToStix, amodeToStix' )
+import StixPrim ( foreignCallCode, amodeToStix, amodeToStix' )
import Outputable ( pprPanic, ppr )
import UniqSupply ( returnUs, thenUs, mapUs, getUniqueUs, UniqSM )
import Util ( naturalMergeSortLe )
import Name ( NamedThing(..) )
import CmdLineOpts ( opt_Static, opt_EnsureSplittableC )
import Outputable ( assertPanic )
+
+-- DEBUGGING ONLY
+--import IOExts ( trace )
+--import Outputable ( showSDoc )
+--import MachOp ( pprMachOp )
+
\end{code}
For each independent chunk of AbstractC code, we generate a list of
performed locally within the chunk.
\begin{code}
-genCodeAbstractC :: AbstractC -> UniqSM [StixTree]
+genCodeAbstractC :: AbstractC -> UniqSM [StixStmt]
genCodeAbstractC absC
= gentopcode absC
a2stix' = amodeToStix'
volsaves = volatileSaves
volrestores = volatileRestores
- p2stix = primCode
macro_code = macroCode
-- real code follows... ---------
\end{code}
, StData DataPtrRep (map mk_StCLbl_for_SRT closures)
]
where
- mk_StCLbl_for_SRT :: CLabel -> StixTree
+ mk_StCLbl_for_SRT :: CLabel -> StixExpr
mk_StCLbl_for_SRT label
| labelDynamic label
= StIndex Int8Rep (StCLbl label) (StInt 1)
: StData IntRep [StInt 0]
: StSegment TextSegment
: StLabel lbl
- : StCondJump tmp_lbl (StPrim IntNeOp
+ : StCondJump tmp_lbl (StMachOp MO_Nat_Ne
[StInd IntRep (StCLbl flag_lbl),
StInt 0])
- : StAssign IntRep (StInd IntRep (StCLbl flag_lbl)) (StInt 1)
+ : StAssignMem IntRep (StCLbl flag_lbl) (StInt 1)
: code
[ StLabel tmp_lbl
- , StAssign PtrRep stgSp
- (StIndex PtrRep stgSp (StInt (-1)))
- , StJump NoDestInfo (StInd WordRep stgSp)
+ , StAssignReg PtrRep stgSp
+ (StIndex PtrRep (StReg stgSp) (StInt (-1)))
+ , StJump NoDestInfo (StInd WordRep (StReg stgSp))
])
gentopcode absC
gencode c2 `thenUs` \ b2 ->
returnUs (b1 . b2)
+ gencode (CSequential stuff)
+ = foo stuff
+ where
+ foo [] = returnUs id
+ foo (s:ss) = gencode s `thenUs` \ stix ->
+ foo ss `thenUs` \ stixes ->
+ returnUs (stix . stixes)
+
\end{code}
Initialising closure headers in the heap...a fairly complex ordeal if
lhs = a2stix reg_rel
lbl = infoTableLabelFromCI cl_info
in
- returnUs (\xs -> StAssign PtrRep (StInd PtrRep lhs) (StCLbl lbl) : xs)
+ returnUs (\xs -> StAssignMem PtrRep lhs (StCLbl lbl) : xs)
\end{code}
lhs' = a2stix lhs
rhs' = a2stix' rhs
in
- returnUs (\xs -> StAssign pk' lhs' rhs' : xs)
+ returnUs (\xs -> mkStAssign pk' lhs' rhs' : xs)
\end{code}
= returnUs (\xs -> StJump NoDestInfo dest : xs)
where
dest = StInd PtrRep (StIndex PtrRep (a2stix table) dyn_off)
- dyn_off = StPrim IntSubOp [StPrim IntNegOp [a2stix am],
- StInt (toInteger (fixedItblSize+1))]
+ dyn_off = StMachOp MO_Nat_Sub [StMachOp MO_NatS_Neg [a2stix am],
+ StInt (toInteger (fixedItblSize+1))]
\end{code}
foreignCallCode (nonVoid results) fcall (nonVoid args)
gencode (COpStmt results (StgPrimOp op) args vols)
- -- ToDo (ADR?): use that liveness mask
- | primOpNeedsWrapper op
- = let
- saves = volsaves vols
- restores = volrestores vols
+ = panic "AbsCStixGen.gencode: un-translated PrimOp"
+
+ -- Translate out array indexing primops right here, so that
+ -- individual targets don't have to deal with them
+
+ gencode (CMachOpStmt (Just1 r1) (MO_ReadOSBI off_w rep) [base,index] vols)
+ = returnUs (\xs ->
+ mkStAssign
+ rep
+ (a2stix r1)
+ (StInd rep (StMachOp MO_Nat_Add
+ [StIndex rep (a2stix base) (a2stix index),
+ StInt (toInteger (off_w * wORD_SIZE))]))
+ : xs
+ )
+
+ gencode (CMachOpStmt Just0 (MO_WriteOSBI off_w rep) [base,index,val] vols)
+ = returnUs (\xs ->
+ StAssignMem
+ rep
+ (StMachOp MO_Nat_Add
+ [StIndex rep (a2stix base) (a2stix index),
+ StInt (toInteger (off_w * wORD_SIZE))])
+ (a2stix val)
+ : xs
+ )
+
+ -- Gruesome cases for multiple-result primops
+ gencode (CMachOpStmt (Just2 r1 r2) mop [arg1, arg2] vols)
+ | mop `elem` [MO_NatS_AddC, MO_NatS_SubC, MO_NatS_MulC]
+ = getUniqueUs `thenUs` \ u1 ->
+ getUniqueUs `thenUs` \ u2 ->
+ let vr1 = StixVReg u1 IntRep
+ vr2 = StixVReg u2 IntRep
+ r1s = a2stix r1
+ r2s = a2stix r2
in
- p2stix (nonVoid results) op (nonVoid args)
- `thenUs` \ code ->
- returnUs (\xs -> saves ++ code (restores ++ xs))
+ returnUs (\xs ->
+ StAssignMachOp (Just2 vr1 vr2) mop [a2stix arg1, a2stix arg2]
+ : mkStAssign IntRep r1s (StReg (StixTemp vr1))
+ : mkStAssign IntRep r2s (StReg (StixTemp vr2))
+ : xs
+ )
+
+ -- Ordinary MachOps are passed through unchanged.
- | otherwise = p2stix (nonVoid results) op (nonVoid args)
+ gencode (CMachOpStmt (Just1 r1) mop args vols)
+ = let (Just1 rep) = resultRepsOfMachOp mop
+ in
+ returnUs (\xs ->
+ mkStAssign rep (a2stix r1)
+ (StMachOp mop (map a2stix args))
+ : xs
+ )
\end{code}
Now the dreaded conditional jump.
mkJumpTable am alts lowTag highTag dflt
= getUniqLabelNCG `thenUs` \ utlbl ->
mapUs genLabel alts `thenUs` \ branches ->
- let cjmpLo = StCondJump dflt (StPrim IntLtOp [am, StInt (toInteger lowTag)])
- cjmpHi = StCondJump dflt (StPrim IntGtOp [am, StInt (toInteger highTag)])
+ let cjmpLo = StCondJump dflt (StMachOp MO_NatS_Lt [am, StInt (toInteger lowTag)])
+ cjmpHi = StCondJump dflt (StMachOp MO_NatS_Gt [am, StInt (toInteger highTag)])
- offset = StPrim IntSubOp [am, StInt lowTag]
+ offset = StMachOp MO_Nat_Sub [am, StInt lowTag]
dsts = DestInfo (dflt : map fst branches)
jump = StJump dsts (StInd PtrRep (StIndex PtrRep (StCLbl utlbl) offset))
| rangeOfOne = gencode alt
| otherwise
= let tag' = a2stix (CLit tag)
- cmpOp = if floating then DoubleNeOp else IntNeOp
- test = StPrim cmpOp [am, tag']
+ cmpOp = if floating then MO_Dbl_Ne else MO_Nat_Ne
+ test = StMachOp cmpOp [am, tag']
cjmp = StCondJump udlbl test
in
gencode alt `thenUs` \ alt_code ->
mkBinaryTree am floating alts choices lowTag highTag udlbl
= getUniqLabelNCG `thenUs` \ uhlbl ->
let tag' = a2stix (CLit splitTag)
- cmpOp = if floating then DoubleGeOp else IntGeOp
- test = StPrim cmpOp [am, tag']
+ cmpOp = if floating then MO_Dbl_Ge else MO_NatS_Ge
+ test = StMachOp cmpOp [am, tag']
cjmp = StCondJump uhlbl test
in
mkBinaryTree am floating alts_lo half lowTag splitTag udlbl
getUniqLabelNCG `thenUs` \ utlbl ->
let discrim' = a2stix discrim
tag' = a2stix (CLit tag)
- cmpOp = if (isFloatingRep (getAmodeRep discrim)) then DoubleNeOp else IntNeOp
- test = StPrim cmpOp [discrim', tag']
+ cmpOp = if (isFloatingRep (getAmodeRep discrim)) then MO_Dbl_Ne else MO_Nat_Ne
+ test = StMachOp cmpOp [discrim', tag']
cjmp = StCondJump utlbl test
dest = StLabel utlbl
join = StLabel ujlbl
gencode deflt `thenUs` \ dflt_code ->
returnUs (\xs -> cjmp : alt_code (dest : dflt_code (join : xs)))
-mkJoin :: AbstractC -> CLabel -> AbstractC
+mkJoin :: AbstractC -> CLabel -> AbstractC
mkJoin code lbl
| mightFallThrough code = mkAbsCStmts code (CJump (CLbl lbl PtrRep))
| otherwise = code
projects / ghc-hetmet.git / blobdiff