%
-% (c) The AQUA Project, Glasgow University, 1993-1996
+% (c) The AQUA Project, Glasgow University, 1993-1998
%
\begin{code}
-#include "HsVersions.h"
-
module AbsCStixGen ( genCodeAbstractC ) where
-IMP_Ubiq(){-uitous-}
+#include "HsVersions.h"
+
+import Ratio ( Rational )
import AbsCSyn
import Stix
-
import MachMisc
-import MachRegs
import AbsCUtils ( getAmodeRep, mixedTypeLocn,
nonemptyAbsC, mkAbsCStmts, mkAbsCStmtList
)
-import CgCompInfo ( mIN_UPD_SIZE )
+import SMRep ( fixedItblSize,
+ rET_SMALL, rET_BIG,
+ rET_VEC_SMALL, rET_VEC_BIG
+ )
+import Constants ( mIN_UPD_SIZE )
+import CLabel ( CLabel, mkReturnInfoLabel, mkReturnPtLabel )
import ClosureInfo ( infoTableLabelFromCI, entryLabelFromCI,
- fastLabelFromCI, closureUpdReqd
+ fastLabelFromCI, closureUpdReqd,
+ staticClosureNeedsLink
)
-import HeapOffs ( hpRelToInt )
-import Literal ( Literal(..) )
+import Const ( Literal(..) )
import Maybes ( maybeToBool )
-import OrdList ( OrdList )
import PrimOp ( primOpNeedsWrapper, PrimOp(..) )
import PrimRep ( isFloatingRep, PrimRep(..) )
-import StixInfo ( genCodeInfoTable )
-import StixMacro ( macroCode )
+import StixInfo ( genCodeInfoTable, genBitmapInfoTable )
+import StixMacro ( macroCode, checkCode )
import StixPrim ( primCode, amodeToStix, amodeToStix' )
-import UniqSupply ( returnUs, thenUs, mapUs, getUnique, UniqSM(..) )
-import Util ( naturalMergeSortLe, panic )
+import UniqSupply ( returnUs, thenUs, mapUs, getUniqueUs, UniqSM )
+import Util ( naturalMergeSortLe )
+import Panic ( panic )
+import BitSet ( intBS )
#ifdef REALLY_HASKELL_1_3
ord = fromEnum :: Char -> Int
volrestores = volatileRestores
p2stix = primCode
macro_code = macroCode
- hp_rel = hpRelToInt
-- real code follows... ---------
\end{code}
= genCodeStaticClosure stmt `thenUs` \ code ->
returnUs (StSegment DataSegment : StLabel label : code [])
- gentopcode stmt@(CRetUnVector _ _) = returnUs []
-
- gentopcode stmt@(CFlatRetVector label _)
+ gentopcode stmt@(CRetVector label _ _ _)
= genCodeVecTbl stmt `thenUs` \ code ->
returnUs (StSegment TextSegment : code [StLabel label])
- gentopcode stmt@(CClosureInfoAndCode cl_info slow Nothing _ _ _)
+ gentopcode stmt@(CRetDirect uniq absC srt liveness)
+ = gencode absC `thenUs` \ code ->
+ genBitmapInfoTable liveness srt closure_type False `thenUs` \ itbl ->
+ returnUs (StSegment TextSegment :
+ itbl (StLabel lbl_info : StLabel lbl_ret : code []))
+ where
+ lbl_info = mkReturnInfoLabel uniq
+ lbl_ret = mkReturnPtLabel uniq
+ closure_type = case liveness of
+ LvSmall _ -> rET_SMALL
+ LvLarge _ -> rET_BIG
+
+ gentopcode stmt@(CClosureInfoAndCode cl_info slow Nothing _)
| slow_is_empty
= genCodeInfoTable stmt `thenUs` \ itbl ->
slow_is_empty = not (maybeToBool (nonemptyAbsC slow))
slow_lbl = entryLabelFromCI cl_info
- gentopcode stmt@(CClosureInfoAndCode cl_info slow (Just fast) _ _ _) =
+ gentopcode stmt@(CClosureInfoAndCode cl_info slow (Just fast) _) =
-- ToDo: what if this is empty? ------------------------^^^^
genCodeInfoTable stmt `thenUs` \ itbl ->
gencode slow `thenUs` \ slow_code ->
slow_lbl = entryLabelFromCI cl_info
fast_lbl = fastLabelFromCI cl_info
+ gentopcode stmt@(CSRT lbl closures)
+ = returnUs [ StSegment TextSegment
+ , StLabel lbl
+ , StData DataPtrRep (map StCLbl closures)
+ ]
+
+ gentopcode stmt@(CBitmap lbl mask)
+ = returnUs [ StSegment TextSegment
+ , StLabel lbl
+ , StData WordRep (StInt (toInteger (length mask)) :
+ map (StInt . toInteger . intBS) mask)
+ ]
+
gentopcode absC
= gencode absC `thenUs` \ code ->
returnUs (StSegment TextSegment : code [])
\end{code}
-Vector tables are trivial!
-
\begin{code}
{-
genCodeVecTbl
:: AbstractC
-> UniqSM StixTreeList
-}
- genCodeVecTbl (CFlatRetVector label amodes)
- = returnUs (\xs -> vectbl : xs)
+ genCodeVecTbl (CRetVector label amodes srt liveness)
+ = genBitmapInfoTable liveness srt closure_type True `thenUs` \itbl ->
+ returnUs (\xs -> vectbl : itbl xs)
where
vectbl = StData PtrRep (reverse (map a2stix amodes))
+ closure_type = case liveness of
+ LvSmall _ -> rET_VEC_SMALL
+ LvLarge _ -> rET_VEC_BIG
\end{code}
-Static closures are not so hard either.
-
\begin{code}
{-
genCodeStaticClosure
-> UniqSM StixTreeList
-}
genCodeStaticClosure (CStaticClosure _ cl_info cost_centre amodes)
- = returnUs (\xs -> table : xs)
+ = returnUs (\xs -> table ++ xs)
where
- table = StData PtrRep (StCLbl info_lbl : body)
- info_lbl = infoTableLabelFromCI cl_info
+ table = StData PtrRep [StCLbl (infoTableLabelFromCI cl_info)] :
+ map (\amode -> StData (getAmodeRep amode) [a2stix amode]) amodes ++
+ [StData PtrRep (padding_wds ++ static_link)]
- body = if closureUpdReqd cl_info then
- take (max mIN_UPD_SIZE (length amodes')) (amodes' ++ zeros)
- else
- amodes'
+ -- always at least one padding word: this is the static link field
+ -- for the garbage collector.
+ padding_wds = if closureUpdReqd cl_info then
+ take (max 0 (mIN_UPD_SIZE - length amodes)) zeros
+ else
+ []
- zeros = StInt 0 : zeros
+ static_link | staticClosureNeedsLink cl_info = [StInt 0]
+ | otherwise = []
- amodes' = map amodeZeroVoid amodes
+ zeros = StInt 0 : zeros
+ {- needed??? --SDM
-- Watch out for VoidKinds...cf. PprAbsC
amodeZeroVoid item
| getAmodeRep item == VoidRep = StInt 0
| otherwise = a2stix item
+ -}
\end{code}
\begin{code}
- gencode (CInitHdr cl_info reg_rel _ _)
+ gencode (CInitHdr cl_info reg_rel _)
= let
- lhs = a2stix (CVal reg_rel PtrRep)
+ lhs = a2stix reg_rel
lbl = infoTableLabelFromCI cl_info
in
- returnUs (\xs -> StAssign PtrRep lhs (StCLbl lbl) : xs)
+ returnUs (\xs -> StAssign PtrRep (StInd PtrRep lhs) (StCLbl lbl) : xs)
+
+\end{code}
+
+Heap/Stack Checks.
+
+\begin{code}
+
+ gencode (CCheck macro args assts)
+ = gencode assts `thenUs` \assts_stix ->
+ checkCode macro args assts_stix
\end{code}
Note that the new entry convention requires that we load the InfoPtr (R2)
with the address of the info table before jumping to the entry code for Node.
+For a vectored return, we must subtract the size of the info table to
+get at the return vector. This depends on the size of the info table,
+which varies depending on whether we're profiling etc.
+
\begin{code}
gencode (CJump dest)
= returnUs (\xs -> StJump dest : xs)
where
dest = StInd PtrRep (StIndex PtrRep (a2stix table)
- (StInt (toInteger (-n-1))))
+ (StInt (toInteger (-n-fixedItblSize-1))))
gencode (CReturn table (DynamicVectoredReturn am))
= returnUs (\xs -> StJump dest : xs)
where
dest = StInd PtrRep (StIndex PtrRep (a2stix table) dyn_off)
- dyn_off = StPrim IntSubOp [StPrim IntNegOp [a2stix am], StInt 1]
+ dyn_off = StPrim IntSubOp [StPrim IntNegOp [a2stix am],
+ StInt (toInteger (fixedItblSize+1))]
\end{code}
\begin{code}
- gencode (COpStmt results op args liveness_mask vols)
+ gencode (COpStmt results op args vols)
-- ToDo (ADR?): use that liveness mask
| primOpNeedsWrapper op
= let
other | simple_discrim -> mkSimpleSwitches discrim alts deflt
-- Otherwise, we need to do a bit of work.
- other -> getUnique `thenUs` \ u ->
+ other -> getUniqueUs `thenUs` \ u ->
gencode (AbsCStmts
(CAssign (CTemp u pk) discrim)
(CSwitch (CTemp u pk) alts deflt))
\end{code}
-Here, we generate a jump table if there are more than four (integer) alternatives and
-the jump table occupancy is greater than 50%. Otherwise, we generate a binary
-comparison tree. (Perhaps this could be tuned.)
+Here, we generate a jump table if there are more than four (integer)
+alternatives and the jump table occupancy is greater than 50%.
+Otherwise, we generate a binary comparison tree. (Perhaps this could
+be tuned.)
\begin{code}
intTag :: Literal -> Integer
- intTag (MachChar c) = toInteger (ord c)
+ intTag (MachChar c) = fromInt (ord c)
intTag (MachInt i _) = i
intTag _ = panic "intTag"
mkJumpTable am alts lowTag highTag dflt
= getUniqLabelNCG `thenUs` \ utlbl ->
mapUs genLabel alts `thenUs` \ branches ->
- let cjmpLo = StCondJump dflt (StPrim IntLtOp [am, StInt lowTag])
- cjmpHi = StCondJump dflt (StPrim IntGtOp [am, StInt highTag])
+ let cjmpLo = StCondJump dflt (StPrim IntLtOp [am, StInt (toInteger lowTag)])
+ cjmpHi = StCondJump dflt (StPrim IntGtOp [am, StInt (toInteger highTag)])
offset = StPrim IntSubOp [am, StInt lowTag]
- jump = StJump (StInd PtrRep (StIndex PtrRep (StCLbl utlbl) offset))
+ jump = StJump (StInd PtrRep (StIndex PtrRep (StCLbl utlbl) offset))
tlbl = StLabel utlbl
table = StData PtrRep (mkTable branches [lowTag..highTag] [])
in
projects / ghc-hetmet.git / blobdiff