%
-% (c) The AQUA Project, Glasgow University, 1993-1995
+% (c) The AQUA Project, Glasgow University, 1993-1996
%
\begin{code}
#include "HsVersions.h"
-module StixMacro (
- genMacroCode, doHeapCheck, smStablePtrTable,
+module StixMacro ( macroCode, heapCheck ) where
- Target, StixTree, UniqSupply, CAddrMode, CExprMacro,
- CStmtMacro
- ) where
+import Ubiq{-uitious-}
+import NcgLoop ( amodeToStix )
-import AbsCSyn
-import PrelInfo ( PrimOp(..)
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
- )
-import MachDesc {- lots -}
-import CgCompInfo ( sTD_UF_SIZE, uF_RET, uF_SUA, uF_SUB, uF_UPDATEE )
+import MachMisc
+import MachRegs
+
+import AbsCSyn ( CStmtMacro(..), MagicId(..), mkIntCLit, CAddrMode )
+import CgCompInfo ( uF_RET, uF_SUA, uF_SUB, uF_UPDATEE,
+ sTD_UF_SIZE
+ )
+import OrdList ( OrdList )
+import PrimOp ( PrimOp(..) )
+import PrimRep ( PrimRep(..) )
import Stix
-import UniqSupply
-import Util
+import UniqSupply ( returnUs, thenUs, UniqSM(..) )
\end{code}
The @ARGS_CHK_A{_LOAD_NODE}@ macros check for sufficient arguments on
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
+macroCode
+ :: CStmtMacro -- statement macro
-> [CAddrMode] -- args
-> UniqSM StixTreeList
-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 `thenUs` \ ulbl ->
- let [words, lbl] = map a2stix args
- temp = StIndex PtrRep stgSpA words
- test = StPrim AddrGeOp [stgSuA, temp]
- cjmp = StCondJump ulbl test
- assign = StAssign PtrRep stgNode lbl
- join = StLabel ulbl
+macroCode ARGS_CHK_A_LOAD_NODE args
+ = getUniqLabelNCG `thenUs` \ ulbl ->
+ let
+ [words, lbl] = map amodeToStix args
+ temp = StIndex PtrRep stgSpA words
+ test = StPrim AddrGeOp [stgSuA, temp]
+ cjmp = StCondJump ulbl test
+ assign = StAssign PtrRep stgNode lbl
+ join = StLabel ulbl
in
- returnUs (\xs -> cjmp : assign : updatePAP : join : xs)
+ returnUs (\xs -> cjmp : assign : updatePAP : join : xs)
- genmacro ARGS_CHK_A [words] =
- getUniqLabelNCG `thenUs` \ ulbl ->
- let temp = StIndex PtrRep stgSpA (a2stix words)
+macroCode ARGS_CHK_A [words]
+ = getUniqLabelNCG `thenUs` \ ulbl ->
+ let temp = StIndex PtrRep stgSpA (amodeToStix words)
test = StPrim AddrGeOp [stgSuA, temp]
cjmp = StCondJump ulbl test
join = StLabel ulbl
in
- returnUs (\xs -> cjmp : updatePAP : join : xs)
-
+ returnUs (\xs -> cjmp : updatePAP : join : xs)
\end{code}
Like the macros above, the @ARGS_CHK_B{_LOAD_NODE}@ macros check for
directions are swapped relative to the A stack.
\begin{code}
-
- genmacro ARGS_CHK_B_LOAD_NODE args =
- getUniqLabelNCG `thenUs` \ ulbl ->
- let [words, lbl] = map a2stix args
+macroCode ARGS_CHK_B_LOAD_NODE args
+ = getUniqLabelNCG `thenUs` \ ulbl ->
+ let
+ [words, lbl] = map amodeToStix args
temp = StIndex PtrRep stgSuB (StPrim IntNegOp [words])
test = StPrim AddrGeOp [stgSpB, temp]
cjmp = StCondJump ulbl test
assign = StAssign PtrRep stgNode lbl
join = StLabel ulbl
in
- returnUs (\xs -> cjmp : assign : updatePAP : join : xs)
+ returnUs (\xs -> cjmp : assign : updatePAP : join : xs)
- genmacro ARGS_CHK_B [words] =
- getUniqLabelNCG `thenUs` \ ulbl ->
- let temp = StIndex PtrRep stgSuB (StPrim IntNegOp [a2stix words])
+macroCode ARGS_CHK_B [words]
+ = getUniqLabelNCG `thenUs` \ ulbl ->
+ let
+ temp = StIndex PtrRep stgSuB (StPrim IntNegOp [amodeToStix words])
test = StPrim AddrGeOp [stgSpB, temp]
cjmp = StCondJump ulbl test
join = StLabel ulbl
in
- returnUs (\xs -> cjmp : updatePAP : join : xs)
-
+ returnUs (\xs -> cjmp : updatePAP : join : xs)
\end{code}
The @HEAP_CHK@ macro checks to see that there are enough words
available in the heap (before reaching @HpLim@). When a heap check
fails, it has to call @PerformGC@ via the @PerformGC_wrapper@. The
-call wrapper saves all of our volatile registers so that we don't have to.
+call wrapper saves all of our volatile registers so that we don't have
+to.
-Since there are @HEAP_CHK@s buried at unfortunate places in the integer
-primOps, this is just a wrapper.
+Since there are @HEAP_CHK@s buried at unfortunate places in the
+integer primOps, this is just a wrapper.
\begin{code}
-
- genmacro HEAP_CHK args =
- let [liveness,words,reenter] = map a2stix args
+macroCode HEAP_CHK args
+ = let [liveness,words,reenter] = map amodeToStix args
in
- doHeapCheck liveness words reenter
+ heapCheck liveness words reenter
\end{code}
The @STK_CHK@ macro checks for enough space on the stack between @SpA@
so we don't have to @callWrapper@ it.
\begin{code}
-
- genmacro STK_CHK [liveness, aWords, bWords, spa, spb, prim, reenter] =
+macroCode STK_CHK [liveness, aWords, bWords, spa, spb, prim, reenter]
+ =
{- Need to check to see if we are compiling with stack checks
- getUniqLabelNCG `thenUs` \ ulbl ->
+ getUniqLabelNCG `thenUs` \ ulbl ->
let words = StPrim IntNegOp
- [StPrim IntAddOp [a2stix aWords, a2stix bWords]]
+ [StPrim IntAddOp [amodeToStix aWords, amodeToStix bWords]]
temp = StIndex PtrRep stgSpA words
test = StPrim AddrGtOp [temp, stgSpB]
cjmp = StCondJump ulbl test
returnUs (\xs -> cjmp : stackOverflow : join : xs)
-}
returnUs id
-
\end{code}
-@UPD_CAF@ involves changing the info pointer of the closure, adding an indirection,
-and putting the new CAF on a linked list for the storage manager.
+@UPD_CAF@ involves changing the info pointer of the closure, adding an
+indirection, and putting the new CAF on a linked list for the storage
+manager.
\begin{code}
-
- genmacro UPD_CAF args =
- let [cafptr,bhptr] = map a2stix args
+macroCode UPD_CAF args
+ = let
+ [cafptr,bhptr] = map amodeToStix args
w0 = StInd PtrRep cafptr
w1 = StInd PtrRep (StIndex PtrRep cafptr (StInt 1))
w2 = StInd PtrRep (StIndex PtrRep cafptr (StInt 2))
a3 = StAssign PtrRep w2 bhptr
a4 = StAssign PtrRep smCAFlist cafptr
in
- returnUs (\xs -> a1 : a2 : a3 : a4 : xs)
-
+ returnUs (\xs -> a1 : a2 : a3 : a4 : xs)
\end{code}
@UPD_IND@ is complicated by the fact that we are supporting the
if we update an old generation object.
\begin{code}
-
- genmacro UPD_IND args =
- getUniqLabelNCG `thenUs` \ ulbl ->
- let [updptr, heapptr] = map a2stix args
+macroCode UPD_IND args
+ = getUniqLabelNCG `thenUs` \ ulbl ->
+ let
+ [updptr, heapptr] = map amodeToStix args
test = StPrim AddrGtOp [updptr, smOldLim]
cjmp = StCondJump ulbl test
updRoots = StAssign PtrRep smOldMutables updptr
upd2 = StAssign PtrRep (StInd PtrRep
(StIndex PtrRep updptr (StInt 2))) heapptr
in
- returnUs (\xs -> cjmp : upd1 : updRoots : join : upd0 : upd2 : xs)
-
+ returnUs (\xs -> cjmp : upd1 : updRoots : join : upd0 : upd2 : xs)
\end{code}
@UPD_INPLACE_NOPTRS@ is only needed for ticky-ticky profiling.
\begin{code}
-
- genmacro UPD_INPLACE_NOPTRS args = returnUs id
-
+macroCode UPD_INPLACE_NOPTRS args = returnUs id
\end{code}
@UPD_INPLACE_PTRS@ is complicated by the fact that we are supporting
-the Appel-style garbage collector by default. This means some extra work
-if we update an old generation object.
+the Appel-style garbage collector by default. This means some extra
+work if we update an old generation object.
\begin{code}
-
- genmacro UPD_INPLACE_PTRS [liveness] =
- getUniqLabelNCG `thenUs` \ ulbl ->
+macroCode UPD_INPLACE_PTRS [liveness]
+ = getUniqLabelNCG `thenUs` \ ulbl ->
let cjmp = StCondJump ulbl testOldLim
testOldLim = StPrim AddrGtOp [stgNode, smOldLim]
join = StLabel ulbl
updOldMutables = StAssign PtrRep smOldMutables stgNode
updUpdReg = StAssign PtrRep stgNode hpBack2
in
- genmacro HEAP_CHK [liveness, mkIntCLit_3, mkIntCLit_0]
- `thenUs` \ heap_chk ->
- returnUs (\xs -> (cjmp :
- heap_chk (updUpd0 : updUpd1 : updUpd2 :
- updOldMutables : updUpdReg : join : xs)))
-
+ macroCode HEAP_CHK [liveness, mkIntCLit_3, mkIntCLit_0]
+ `thenUs` \ heap_chk ->
+ returnUs (\xs -> (cjmp :
+ heap_chk (updUpd0 : updUpd1 : updUpd2 :
+ updOldMutables : updUpdReg : join : xs)))
\end{code}
@UPD_BH_UPDATABLE@ is only used when running concurrent threads (in
to handle @UPD_BH_SINGLE_ENTRY@ in all cases.
\begin{code}
+macroCode UPD_BH_UPDATABLE args = returnUs id
- genmacro UPD_BH_UPDATABLE args = returnUs id
-
- genmacro UPD_BH_SINGLE_ENTRY [arg] =
- let
- update = StAssign PtrRep (StInd PtrRep (a2stix arg)) bh_info
+macroCode UPD_BH_SINGLE_ENTRY [arg]
+ = let
+ update = StAssign PtrRep (StInd PtrRep (amodeToStix arg)) bh_info
in
- returnUs (\xs -> update : xs)
-
+ returnUs (\xs -> update : xs)
\end{code}
Push a four word update frame on the stack and slide the Su[AB]
registers to the current Sp[AB] locations.
\begin{code}
-
- genmacro PUSH_STD_UPD_FRAME args =
- let [bhptr, aWords, bWords] = map a2stix args
+macroCode PUSH_STD_UPD_FRAME args
+ = let
+ [bhptr, aWords, bWords] = map amodeToStix args
frame n = StInd PtrRep
(StIndex PtrRep stgSpB (StPrim IntAddOp
[bWords, StInt (toInteger (sTD_UF_SIZE - n))]))
updSuA = StAssign PtrRep
stgSuA (StIndex PtrRep stgSpA (StPrim IntNegOp [aWords]))
in
- returnUs (\xs -> a1 : a2 : a3 : a4 : updSuB : updSuA : xs)
-
+ returnUs (\xs -> a1 : a2 : a3 : a4 : updSuB : updSuA : xs)
\end{code}
Pop a standard update frame.
\begin{code}
-
- genmacro POP_STD_UPD_FRAME args =
- let frame n = StInd PtrRep (StIndex PtrRep stgSpB (StInt (toInteger (-n))))
+macroCode POP_STD_UPD_FRAME args
+ = let
+ frame n = StInd PtrRep (StIndex PtrRep stgSpB (StInt (toInteger (-n))))
grabRet = StAssign PtrRep stgRetReg (frame uF_RET)
grabSuB = StAssign PtrRep stgSuB (frame uF_SUB)
updSpB = StAssign PtrRep
stgSpB (StIndex PtrRep stgSpB (StInt (toInteger (-sTD_UF_SIZE))))
in
- returnUs (\xs -> grabRet : grabSuB : grabSuA : updSpB : xs)
-
+ returnUs (\xs -> grabRet : grabSuB : grabSuA : updSpB : xs)
\end{code}
The @SET_ARITY@ and @CHK_ARITY@ macros are disabled for ``normal''
compilation.
\begin{code}
- genmacro SET_ARITY args = returnUs id
- genmacro CHK_ARITY args = returnUs id
+macroCode SET_ARITY args = returnUs id
+macroCode CHK_ARITY args = returnUs id
\end{code}
This one only applies if we have a machine register devoted to TagReg.
\begin{code}
- genmacro SET_TAG [tag] =
- let set_tag = StAssign IntRep stgTagReg (a2stix tag)
+macroCode SET_TAG [tag]
+ = let set_tag = StAssign IntRep stgTagReg (amodeToStix tag)
in
- case stg_reg TagReg of
- Always _ -> returnUs id
- Save _ -> returnUs (\ xs -> set_tag : xs)
+ case stgReg TagReg of
+ Always _ -> returnUs id
+ Save _ -> returnUs (\ xs -> set_tag : xs)
\end{code}
Do the business for a @HEAP_CHK@, having converted the args to Trees
of StixOp.
\begin{code}
-
-doHeapCheck
- :: {- unused now: Target
- -> -}StixTree -- liveness
+heapCheck
+ :: StixTree -- liveness
-> StixTree -- words needed
-> StixTree -- always reenter node? (boolean)
-> UniqSM StixTreeList
-doHeapCheck {-target:unused now-} liveness words reenter =
- getUniqLabelNCG `thenUs` \ ulbl ->
+heapCheck liveness words reenter
+ = getUniqLabelNCG `thenUs` \ ulbl ->
let newHp = StIndex PtrRep stgHp words
assign = StAssign PtrRep stgHp newHp
test = StPrim AddrLeOp [stgHp, stgHpLim]
gc = StCall SLIT("PerformGC_wrapper") VoidRep [arg]
join = StLabel ulbl
in
- returnUs (\xs -> assign : cjmp : gc : join : xs)
-
+ returnUs (\xs -> assign : cjmp : gc : join : xs)
\end{code}
Let's make sure that these CAFs are lifted out, shall we?
\begin{code}
-
-- Some common labels
bh_info, caf_info, ind_info :: StixTree
updatePAP = StJump (sStLitLbl SLIT("UpdatePAP"))
stackOverflow = StCall SLIT("StackOverflow") VoidRep []
-
-\end{code}
-
-Storage manager nonsense. Note that the indices are dependent on
-the definition of the smInfo structure in SMinterface.lh
-
-\begin{code}
-
-#include "../../includes/platform.h"
-
-#if alpha_TARGET_ARCH
-#include "../../includes/alpha-dec-osf1.h"
-#else
-#if sunos4_TARGET_OS
-#include "../../includes/sparc-sun-sunos4.h"
-#else
-#include "../../includes/sparc-sun-solaris2.h"
-#endif
-#endif
-
-storageMgrInfo, smCAFlist, smOldMutables, smOldLim :: StixTree
-
-storageMgrInfo = sStLitLbl SLIT("StorageMgrInfo")
-smCAFlist = StInd PtrRep (StIndex PtrRep storageMgrInfo (StInt SM_CAFLIST))
-smOldMutables = StInd PtrRep (StIndex PtrRep storageMgrInfo (StInt SM_OLDMUTABLES))
-smOldLim = StInd PtrRep (StIndex PtrRep storageMgrInfo (StInt SM_OLDLIM))
-
-smStablePtrTable = StInd PtrRep
- (StIndex PtrRep storageMgrInfo (StInt SM_STABLEPOINTERTABLE))
-
\end{code}
projects / ghc-hetmet.git / blobdiff