%
-% (c) The AQUA Project, Glasgow University, 1993-1996
+% (c) The AQUA Project, Glasgow University, 1993-1998
%
\begin{code}
import AbsCUtils ( getAmodeRep, mixedTypeLocn,
nonemptyAbsC, mkAbsCStmts, mkAbsCStmtList
)
+import SMRep ( fixedItblSize,
+ rET_SMALL, rET_BIG,
+ rET_VEC_SMALL, rET_VEC_BIG
+ )
import Constants ( mIN_UPD_SIZE )
-import CLabel ( CLabel )
+import CLabel ( CLabel, mkReturnInfoLabel, mkReturnPtLabel )
import ClosureInfo ( infoTableLabelFromCI, entryLabelFromCI,
fastLabelFromCI, closureUpdReqd
)
-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 UniqSupply ( returnUs, thenUs, mapUs, getUniqueUs, UniqSM )
import Util ( naturalMergeSortLe, 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
table = StData PtrRep (StCLbl info_lbl : body)
info_lbl = infoTableLabelFromCI cl_info
+ -- always at least one padding word: this is the static link field
+ -- for the garbage collector.
body = if closureUpdReqd cl_info then
- take (max mIN_UPD_SIZE (length amodes')) (amodes' ++ zeros)
+ take (1 + max mIN_UPD_SIZE (length amodes')) (amodes' ++ zeros)
else
- amodes'
+ amodes' ++ [StInt 0]
zeros = StInt 0 : zeros
\begin{code}
- gencode (CInitHdr cl_info reg_rel _ _)
+ gencode (CInitHdr cl_info reg_rel _)
= let
lhs = a2stix (CVal reg_rel PtrRep)
lbl = infoTableLabelFromCI cl_info
\end{code}
+Heap/Stack Checks.
+
+\begin{code}
+
+ gencode (CCheck macro args assts)
+ = gencode assts `thenUs` \assts_stix ->
+ checkCode macro args assts_stix
+
+\end{code}
+
Assignment, the curse of von Neumann, is the center of the code we
produce. In most cases, the type of the assignment is determined
by the type of the destination. However, when the destination can
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}
projects / ghc-hetmet.git / blobdiff