%
-% (c) The AQUA Project, Glasgow University, 1993-1995
+% (c) The AQUA Project, Glasgow University, 1993-1998
%
\begin{code}
+module StixPrim ( primCode, amodeToStix, amodeToStix' ) where
+
#include "HsVersions.h"
-module StixPrim (
- genPrimCode, amodeCode, amodeCode',
-
- Target, CAddrMode, StixTree, PrimOp, SplitUniqSupply
- ) where
-
-IMPORT_Trace -- ToDo: rm debugging
-
-import AbsCSyn
-import AbsPrel ( PrimOp(..), PrimOpResultInfo(..), TyCon,
- getPrimOpResultInfo, isCompareOp, showPrimOp
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
- )
-import AbsUniType ( cmpTyCon ) -- pragmas only
-import CgCompInfo ( spARelToInt, spBRelToInt )
-import MachDesc
-import Pretty
-import PrimKind ( isFloatingKind )
-import CostCentre
-import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) )
+import MachMisc
+import MachRegs
import Stix
-import StixMacro ( smStablePtrTable )
-import StixInteger {- everything -}
-import SplitUniq
-import Unique
-import Unpretty
-import Util
-
+import StixInteger
+
+import AbsCSyn hiding ( spRel )
+import AbsCUtils ( getAmodeRep, mixedTypeLocn )
+import SMRep ( fixedHdrSize )
+import Literal ( Literal(..), word2IntLit )
+import CallConv ( cCallConv )
+import PrimOp ( PrimOp(..), CCall(..), CCallTarget(..) )
+import PrimRep ( PrimRep(..), isFloatingRep )
+import UniqSupply ( returnUs, thenUs, getUniqueUs, UniqSM )
+import Constants ( mIN_INTLIKE, uF_UPDATEE, bLOCK_SIZE )
+import CLabel ( mkIntlikeClosureLabel, mkCharlikeClosureLabel,
+ mkTopClosureLabel, mkErrorIO_innardsLabel,
+ mkMAP_FROZEN_infoLabel, mkForeignLabel )
+import Outputable
+
+import Char ( ord, isAlpha, isDigit )
+
+#include "NCG.h"
\end{code}
-The main honcho here is genPrimCode, which handles the guts of COpStmts.
+The main honcho here is primCode, which handles the guts of COpStmts.
\begin{code}
-arrayOfData_info = sStLitLbl SLIT("ArrayOfData_info") -- out here to avoid CAF (sigh)
-imMutArrayOfPtrs_info = sStLitLbl SLIT("ImMutArrayOfPtrs_info")
-
-genPrimCode
- :: Target
- -> [CAddrMode] -- results
+primCode
+ :: [CAddrMode] -- results
-> PrimOp -- op
-> [CAddrMode] -- args
- -> SUniqSM StixTreeList
-
+ -> UniqSM StixTreeList
\end{code}
First, the dreaded @ccall@. We can't handle @casm@s.
-Usually, this compiles to an assignment, but when the left-hand side is
-empty, we just perform the call and ignore the result.
-
-ToDo ADR: modify this to handle Malloc Ptrs.
+Usually, this compiles to an assignment, but when the left-hand side
+is empty, we just perform the call and ignore the result.
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@.
+The (MP) integer operations are a true nightmare. Since we don't have
+a convenient abstract way of allocating temporary variables on the (C)
+stack, we use the space just below HpLim for the @MP_INT@ structures,
+and modify our heap check accordingly.
\begin{code}
+-- NB: ordering of clauses somewhere driven by
+-- the desire to getting sane patt-matching behavior
+primCode res@[sr,dr] IntegerNegOp arg@[sa,da]
+ = gmpNegate (sr,dr) (sa,da)
-genPrimCode target [] ErrorIOPrimOp [rhs] =
- let changeTop = StAssign PtrKind topClosure (amodeToStix target rhs)
- in
- returnSUs (\xs -> changeTop : flushStdout : flushStderr : errorIO : xs)
+primCode [res] IntegerCmpOp args@[sa1,da1, sa2,da2]
+ = gmpCompare res (sa1,da1, sa2,da2)
-\end{code}
+primCode [res] IntegerCmpIntOp args@[sa1,da1,ai]
+ = gmpCompareInt res (sa1,da1,ai)
-The (MP) integer operations are a true nightmare. Since we don't have a
-convenient abstract way of allocating temporary variables on the (C) stack,
-we use the space just below HpLim for the @MP_INT@ structures, and modify our
-heap check accordingly.
+primCode [res] Integer2IntOp arg@[sa,da]
+ = gmpInteger2Int res (sa,da)
-\begin{code}
+primCode [res] Integer2WordOp arg@[sa,da]
+ = gmpInteger2Word res (sa,da)
-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
+primCode [res] Int2AddrOp [arg]
+ = simpleCoercion AddrRep res arg
-genPrimCode target res IntegerNegOp arg =
- gmpTake1Return1 target res SLIT("mpz_neg") arg
+primCode [res] Addr2IntOp [arg]
+ = simpleCoercion IntRep res 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
+primCode [res] Int2WordOp [arg]
+ = simpleCoercion IntRep{-WordRep?-} res arg
+primCode [res] Word2IntOp [arg]
+ = simpleCoercion IntRep res arg
\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}
+primCode [res] SameMutableArrayOp args
+ = let
+ compare = StPrim AddrEqOp (map amodeToStix args)
+ assign = StAssign IntRep (amodeToStix res) compare
+ in
+ returnUs (\xs -> assign : xs)
-genPrimCode target [res] IntegerCmpOp args = gmpCompare target res args
-
-genPrimCode target [res] Integer2IntOp arg = gmpInteger2Int target res arg
-
-genPrimCode target res Int2IntegerOp args = gmpInt2Integer target res args
-
-genPrimCode target res Word2IntegerOp args = panic "genPrimCode:Word2IntegerOp"
-
-genPrimCode target res Addr2IntegerOp args = gmpString2Integer target res args
-
-genPrimCode target res FloatEncodeOp args =
- encodeFloatingKind FloatKind target res args
-
-genPrimCode target res DoubleEncodeOp args =
- encodeFloatingKind DoubleKind target res args
-
-genPrimCode target res FloatDecodeOp args =
- decodeFloatingKind FloatKind target res args
-
-genPrimCode target res DoubleDecodeOp args =
- decodeFloatingKind DoubleKind target res args
-
-genPrimCode target res Int2AddrOp arg =
- simpleCoercion target AddrKind res arg
-
-genPrimCode target res Addr2IntOp arg =
- simpleCoercion target IntKind res arg
-
-genPrimCode target res Int2WordOp arg =
- simpleCoercion target IntKind{-WordKind?-} res arg
+primCode res@[_] SameMutableByteArrayOp args
+ = primCode res SameMutableArrayOp args
-genPrimCode target res Word2IntOp arg =
- simpleCoercion target IntKind res arg
+primCode res@[_] SameMutVarOp args
+ = primCode res SameMutableArrayOp args
+primCode res@[_] SameMVarOp args
+ = primCode res SameMutableArrayOp args
\end{code}
-@newArray#@ ops allocate heap space.
+Freezing an array of pointers is a double assignment. We fix the
+header of the ``new'' closure because the lhs is probably a better
+addressing mode for the indirection (most likely, it's a VanillaReg).
\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]
- 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 ->
-
- 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]]
- loc = StIndex PtrKind stgHp
- (StPrim IntNegOp [StPrim IntSubOp [space, StInt 1]])
- assign = StAssign PtrKind result loc
- init1 = StAssign PtrKind (StInd PtrKind loc) arrayOfData_info
- init2 = StAssign IntKind
- (StInd IntKind
- (StIndex IntKind loc
- (StInt (toInteger (fixedHeaderSize target)))))
- (StPrim IntAddOp [words,
- StInt (toInteger (varHeaderSize target
- (DataRep 0)))])
- in
- heapCheck target 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
+primCode [lhs] UnsafeFreezeArrayOp [rhs]
+ = let
+ lhs' = amodeToStix lhs
+ rhs' = amodeToStix rhs
+ header = StInd PtrRep lhs'
+ assign = StAssign PtrRep lhs' rhs'
+ freeze = StAssign PtrRep header mutArrPtrsFrozen_info
in
- returnSUs (\xs -> assign : xs)
-
-genPrimCode target res SameMutableByteArrayOp args =
- genPrimCode target res SameMutableArrayOp args
+ returnUs (\xs -> assign : freeze : xs)
+primCode [lhs] UnsafeFreezeByteArrayOp [rhs]
+ = simpleCoercion PtrRep lhs rhs
\end{code}
-Freezing an array of pointers is a double assignment. We fix the header of
-the ``new'' closure because the lhs is probably a better addressing mode for
-the indirection (most likely, it's a VanillaReg).
+Returning the size of (mutable) byte arrays is just
+an indexing operation.
\begin{code}
-
-genPrimCode target [lhs] UnsafeFreezeArrayOp [rhs] =
- let lhs' = amodeToStix target lhs
- rhs' = amodeToStix target rhs
- header = StInd PtrKind lhs'
- assign = StAssign PtrKind lhs' rhs'
- freeze = StAssign PtrKind header imMutArrayOfPtrs_info
+primCode [lhs] SizeofByteArrayOp [rhs]
+ = let
+ lhs' = amodeToStix lhs
+ rhs' = amodeToStix rhs
+ sz = StIndex IntRep rhs' fixedHS
+ assign = StAssign IntRep lhs' (StInd IntRep sz)
in
- returnSUs (\xs -> assign : freeze : xs)
-
-genPrimCode target lhs UnsafeFreezeByteArrayOp rhs =
- simpleCoercion target PtrKind lhs rhs
+ returnUs (\xs -> assign : xs)
+
+primCode [lhs] SizeofMutableByteArrayOp [rhs]
+ = let
+ lhs' = amodeToStix lhs
+ rhs' = amodeToStix rhs
+ sz = StIndex IntRep rhs' fixedHS
+ assign = StAssign IntRep lhs' (StInd IntRep sz)
+ in
+ returnUs (\xs -> assign : xs)
\end{code}
Most other array primitives translate to simple indexing.
\begin{code}
+primCode lhs@[_] IndexArrayOp args
+ = primCode lhs ReadArrayOp args
+
+primCode [lhs] ReadArrayOp [obj, ix]
+ = let
+ lhs' = amodeToStix lhs
+ obj' = amodeToStix obj
+ ix' = amodeToStix ix
+ base = StIndex IntRep obj' arrPtrsHS
+ assign = StAssign PtrRep lhs' (StInd PtrRep (StIndex PtrRep base ix'))
+ in
+ returnUs (\xs -> assign : xs)
+
+primCode [] WriteArrayOp [obj, ix, v]
+ = let
+ obj' = amodeToStix obj
+ ix' = amodeToStix ix
+ v' = amodeToStix v
+ base = StIndex IntRep obj' arrPtrsHS
+ assign = StAssign PtrRep (StInd PtrRep (StIndex PtrRep base ix')) v'
+ in
+ returnUs (\xs -> assign : xs)
-genPrimCode target lhs IndexArrayOp args =
- genPrimCode target lhs ReadArrayOp args
+primCode lhs@[_] (IndexByteArrayOp pk) args
+ = primCode lhs (ReadByteArrayOp pk) 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)
- 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)
- assign = StAssign PtrKind (StInd PtrKind (StIndex PtrKind base ix')) v'
+-- NB: indexing in "pk" units, *not* in bytes (WDP 95/09)
+
+primCode [lhs] (ReadByteArrayOp pk) [obj, ix]
+ = let
+ lhs' = amodeToStix lhs
+ obj' = amodeToStix obj
+ ix' = amodeToStix ix
+ base = StIndex IntRep obj' arrWordsHS
+ assign = StAssign pk lhs' (StInd pk (StIndex pk base ix'))
in
- returnSUs (\xs -> assign : xs)
+ returnUs (\xs -> assign : xs)
-genPrimCode target lhs (IndexByteArrayOp pk) args =
- genPrimCode target lhs (ReadByteArrayOp pk) args
+primCode lhs@[_] (ReadOffAddrOp pk) args
+ = primCode lhs (IndexOffAddrOp pk) args
-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'))
+primCode [lhs] (IndexOffAddrOp pk) [obj, ix]
+ = let
+ lhs' = amodeToStix lhs
+ obj' = amodeToStix obj
+ ix' = amodeToStix ix
+ assign = StAssign pk lhs' (StInd pk (StIndex pk obj' 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'
+ returnUs (\xs -> assign : xs)
+
+primCode [lhs] (IndexOffForeignObjOp pk) [obj, ix]
+ = let
+ lhs' = amodeToStix lhs
+ obj' = amodeToStix obj
+ ix' = amodeToStix ix
+ obj'' = StIndex AddrRep obj' fixedHS
+ 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'))
+ returnUs (\xs -> assign : xs)
+
+primCode [] (WriteOffAddrOp pk) [obj, ix, v]
+ = let
+ obj' = amodeToStix obj
+ ix' = amodeToStix ix
+ v' = amodeToStix v
+ assign = StAssign pk (StInd pk (StIndex pk obj' ix')) v'
in
- returnSUs (\xs -> assign : xs)
-
+ returnUs (\xs -> assign : xs)
+
+primCode [] (WriteByteArrayOp pk) [obj, ix, v]
+ = let
+ obj' = amodeToStix obj
+ ix' = amodeToStix ix
+ v' = amodeToStix v
+ base = StIndex IntRep obj' arrWordsHS
+ assign = StAssign pk (StInd pk (StIndex pk base ix')) v'
+ in
+ returnUs (\xs -> assign : xs)
+
+primCode [] WriteForeignObjOp [obj, v]
+ = let
+ obj' = amodeToStix obj
+ v' = amodeToStix v
+ obj'' = StIndex AddrRep obj' (StInt 4711) -- fixedHS
+ assign = StAssign AddrRep (StInd AddrRep obj'') v'
+ in
+ returnUs (\xs -> assign : xs)
\end{code}
-Stable pointer operations.
-
-First the easy one.
+ToDo: saving/restoring of volatile regs around ccalls.
\begin{code}
+primCode lhs (CCallOp (CCall (StaticTarget fn) is_asm may_gc cconv)) rhs
+ | is_asm = error "ERROR: Native code generator can't handle casm"
+ | not may_gc = returnUs (\xs -> ccall : xs)
+ | otherwise =
+ save_thread_state `thenUs` \ save ->
+ load_thread_state `thenUs` \ load ->
+ getUniqueUs `thenUs` \ uniq ->
+ let
+ id = StReg (StixTemp uniq IntRep)
+
+ suspend = StAssign IntRep id
+ (StCall SLIT("suspendThread") cconv IntRep [stgBaseReg])
+ resume = StCall SLIT("resumeThread") cconv VoidRep [id]
+ in
+ returnUs (\xs -> save (suspend : ccall : resume : load xs))
-genPrimCode target [lhs] DeRefStablePtrOp [sp] =
- let lhs' = amodeToStix target lhs
- pk = getAmodeKind lhs
- sp' = amodeToStix target sp
- call = StCall SLIT("deRefStablePointer") pk [sp', smStablePtrTable]
- assign = StAssign pk lhs' call
- in
- returnSUs (\xs -> assign : xs)
-
+ where
+ args = map amodeCodeForCCall rhs
+ amodeCodeForCCall x =
+ let base = amodeToStix' x
+ in
+ case getAmodeRep x of
+ ArrayRep -> StIndex PtrRep base arrPtrsHS
+ ByteArrayRep -> StIndex IntRep base arrWordsHS
+ ForeignObjRep -> StIndex PtrRep base fixedHS
+ _ -> base
+
+ ccall = case lhs of
+ [] -> StCall fn cconv VoidRep args
+ [lhs] ->
+ let lhs' = amodeToStix lhs
+ pk = if isFloatingRep (getAmodeRep lhs) then DoubleRep else IntRep
+ in
+ StAssign pk lhs' (StCall fn cconv pk args)
\end{code}
-Now the hard one. For comparison, here's the code from StgMacros:
-
-\begin{verbatim}
-#define makeStablePtrZh(stablePtr,liveness,unstablePtr) \
-do { \
- EXTDATA(MK_INFO_LBL(StablePointerTable)); \
- EXTDATA(UnusedSP); \
- StgStablePtr newSP; \
- \
- if (SPT_EMPTY(StorageMgrInfo.StablePointerTable)) { /* free stack is empty */ \
- I_ OldNoPtrs = SPT_NoPTRS(StorageMgrInfo.StablePointerTable); \
- \
- /* any strictly increasing expression will do here */ \
- I_ NewNoPtrs = OldNoPtrs * 2 + 100; \
- \
- I_ NewSize = DYN_VHS + NewNoPtrs + 1 + NewNoPtrs; \
- P_ SPTable; \
- \
- HEAP_CHK(NO_LIVENESS, _FHS+NewSize, 0); \
- CC_ALLOC(CCC, _FHS+NewSize, SPT_K); /* cc prof */ \
- \
- SPTable = Hp + 1 - (_FHS + NewSize); \
- SET_DYN_HDR(SPTable,StablePointerTable,CCC,NewSize,NewNoPtrs); \
- SAFESTGCALL2(void, (void *, P_, P_), enlargeSPTable, SPTable, StorageMgrInfo.StablePointerTable); \
- StorageMgrInfo.StablePointerTable = SPTable; \
- } \
- \
- newSP = SPT_POP(StorageMgrInfo.StablePointerTable); \
- SPT_SPTR(StorageMgrInfo.StablePointerTable, newSP) = unstablePtr; \
- stablePtr = newSP; \
-} while (0)
-\end{verbatim}
-
-ToDo ADR: finish this. (Boy, this is hard work!)
-
-Notes for ADR:
- trMumbles are now just StMumbles.
- StInt 1 is how to write ``1''
- temporaries are allocated at the end of the heap (see notes in StixInteger)
- Good luck!
-
- --JSM
-
-\begin{pseudocode}
-genPrimCode sty md [lhs] MakeStablePtrOp args =
- let
- -- some useful abbreviations (I'm sure these must exist already)
- add = trPrim . IntAddOp
- sub = trPrim . IntSubOp
- one = trInt [1]
- dec x = trAssign IntKind [x, sub [x, one]]
- inc x = trAssign IntKind [x, add [x, one]]
-
- -- tedious hardwiring in of closure layout offsets (from SMClosures)
- dynHS = 2 + fixedHeaderSize md sty + varHeaderSize md sty DynamicRep
- spt_SIZE c = trIndex PtrKind [c, trInt [fhs + gc_reserved] ]
- spt_NoPTRS c = trIndex PtrKind [c, trInt [fhs + gc_reserved + 1] ]
- spt_SPTR c i = trIndex PtrKind [c, add [trInt [dynHS], i]]
- spt_TOP c = trIndex PtrKind [c, add [trInt [dynHS], spt_NoPTRS c]]
- spt_FREE c i = trIndex PtrKind [c, add [trInt [dynHS], spt_NoPTRS c]]
-
- -- tedious hardwiring in of stack manipulation macros (from SMClosures)
- spt_FULL c lbl =
- trCondJump lbl [trPrim IntEqOp [spt_TOP c, spt_NoPTRS c]]
- spt_EMPTY c lbl =
- trCondJump lbl [trPrim IntEqOp [spt_TOP c, trInt [0]]]
- spt_PUSH c f = [
- trAssign PtrKind [spt_FREE c (spt_TOP c), f],
- inc (spt_TOP c),
- spt_POP c x = [
- dec (spt_TOP c),
- trAssign PtrKind [x, spt_FREE c (spt_TOP c)]
- ]
-
- -- now to get down to business
- lhs' = amodeCode sty md lhs
- [liveness, unstable] = map (amodeCode sty md) args
-
- spt = smStablePtrTable
-
- newSPT = -- a temporary (don't know how to allocate it)
- newSP = -- another temporary
-
- allocNewTable = -- some sort fo heap allocation needed
- copyOldTable = trCall "enlargeSPTable" PtrKind [newSPT, spt]
-
- enlarge =
- allocNewTable ++ [
- copyOldTable,
- trAssign PtrKind [spt, newSPT]
- allocate = [
- spt_POP spt newSP,
- trAssign PtrKind [spt_SPTR spt newSP, unstable],
- trAssign StablePtrKind [lhs', newSP]
- ]
-
+DataToTagOp won't work for 64-bit archs, as it is.
+
+\begin{code}
+primCode [lhs] DataToTagOp [arg]
+ = let lhs' = amodeToStix lhs
+ arg' = amodeToStix arg
+ infoptr = StInd PtrRep arg'
+ word_32 = StInd WordRep (StIndex PtrRep infoptr (StInt (-1)))
+ masked_le32 = StPrim SrlOp [word_32, StInt 16]
+ masked_be32 = StPrim AndOp [word_32, StInt 65535]
+#ifdef WORDS_BIGENDIAN
+ masked = masked_be32
+#else
+ masked = masked_le32
+#endif
+ assign = StAssign IntRep lhs' masked
in
- getUniqLabelCTS `thenCTS` \ oklbl ->
- returnCodes sty md
- (spt_EMPTY spt oklbl : (enlarge ++ (trLabel [oklbl] : allocate)))
-\end{pseudocode}
+ returnUs (\xs -> assign : xs)
+\end{code}
+MutVars are pretty simple.
+#define writeMutVarzh(a,v) (P_)(((StgMutVar *)(a))->var)=(v)
+
+\begin{code}
+primCode [] WriteMutVarOp [aa,vv]
+ = let aa_s = amodeToStix aa
+ vv_s = amodeToStix vv
+ var_field = StIndex PtrRep aa_s fixedHS
+ assign = StAssign PtrRep (StInd PtrRep var_field) vv_s
+ in
+ returnUs (\xs -> assign : xs)
+
+primCode [rr] ReadMutVarOp [aa]
+ = let aa_s = amodeToStix aa
+ rr_s = amodeToStix rr
+ var_field = StIndex PtrRep aa_s fixedHS
+ assign = StAssign PtrRep rr_s (StInd PtrRep var_field)
+ in
+ returnUs (\xs -> assign : xs)
+\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
+primCode lhs op rhs
+ = let
+ lhs' = map amodeToStix lhs
+ rhs' = map amodeToStix' rhs
+ pk = getAmodeRep (head lhs)
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)
+ returnUs (\ xs -> simplePrim pk lhs' op rhs' : xs)
+\end{code}
+\begin{code}
+simpleCoercion
+ :: PrimRep
+ -> CAddrMode
+ -> CAddrMode
+ -> UniqSM StixTreeList
+
+simpleCoercion pk lhs rhs
+ = returnUs (\xs -> StAssign pk (amodeToStix lhs) (amodeToStix rhs) : xs)
\end{code}
-Here we try to rewrite primitives into a form the code generator
-can understand. Any primitives not handled here must be handled
-at the level of the specific code generator.
+Here we try to rewrite primitives into a form the code generator can
+understand. Any primitives not handled here must be handled at the
+level of the specific code generator.
\begin{code}
-
-simplePrim
- :: Target
- -> [StixTree]
- -> PrimOp
- -> [StixTree]
+simplePrim
+ :: PrimRep -- Rep of first destination
+ -> [StixTree] -- Destinations
+ -> PrimOp
+ -> [StixTree]
-> StixTree
-
\end{code}
Now look for something more conventional.
\begin{code}
-
-simplePrim target [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 pk [lhs] op rest = StAssign pk lhs (StPrim op rest)
+simplePrim pk as op bs = 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")
+ = error ("ERROR: primitive operation `"++show 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}
%---------------------------------------------------------------------
Here we generate the Stix code for CAddrModes.
-When a character is fetched from a mixed type location, we have to
-do an extra cast. This is reflected in amodeCode', which is for rhs
+When a character is fetched from a mixed type location, we have to do
+an extra cast. This is reflected in amodeCode', which is for rhs
amodes that might possibly need the extra cast.
\begin{code}
+amodeToStix, amodeToStix' :: CAddrMode -> StixTree
-amodeCode, amodeCode'
- :: Target
- -> CAddrMode
- -> StixTree
-
-amodeCode' target 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 (CVal rr pk) = StInd pk (amodeCode target (CAddr rr))
-
-amodeCode target (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)))
-
-amodeCode target (CAddr (HpRel hp off)) =
- StIndex IntKind stgHp (StInt (toInteger (-(hpRel target (hp `subOff` off)))))
-
-amodeCode target (CAddr (NodeRel off)) =
- StIndex IntKind stgNode (StInt (toInteger (hpRel target off)))
-
-amodeCode target (CReg magic) = StReg (StixMagicId magic)
-amodeCode target (CTemp uniq pk) = StReg (StixTemp uniq pk)
+amodeToStix'{-'-} am@(CVal rr CharRep)
+ | mixedTypeLocn am = StPrim ChrOp [amodeToStix am]
+ | otherwise = amodeToStix am
-amodeCode target (CLbl lbl _) = StCLbl lbl
+amodeToStix' am = amodeToStix am
-amodeCode target (CUnVecLbl dir _) = StCLbl dir
+-----------
+amodeToStix am@(CVal rr CharRep)
+ | mixedTypeLocn am
+ = StInd IntRep (amodeToStix (CAddr rr))
-amodeCode target (CTableEntry base off pk) =
- StInd pk (StIndex pk (amodeCode target base) (amodeCode target off))
+amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
--- For CharLike and IntLike, we attempt some trivial constant-folding here.
+amodeToStix (CAddr (SpRel off))
+ = StIndex PtrRep stgSp (StInt (toInteger IBOX(off)))
-amodeCode target (CCharLike (CLit (MachChar c))) =
- StLitLbl (uppBeside (uppPStr SLIT("CHARLIKE_closures+")) (uppInt off))
- where off = charLikeClosureSize target * ord c
+amodeToStix (CAddr (HpRel off))
+ = StIndex IntRep stgHp (StInt (toInteger (- IBOX(off))))
-amodeCode target (CCharLike x) =
- StPrim IntAddOp [charLike, off]
- where off = StPrim IntMulOp [amodeCode target x,
- StInt (toInteger (charLikeClosureSize target))]
+amodeToStix (CAddr (NodeRel off))
+ = StIndex IntRep stgNode (StInt (toInteger IBOX(off)))
-amodeCode target (CIntLike (CLit (MachInt i _))) =
- StPrim IntAddOp [intLikePtr, StInt off]
- where off = toInteger (intLikeClosureSize target) * i
+amodeToStix (CAddr (CIndex base off pk))
+ = StIndex pk (amodeToStix base) (amodeToStix off)
-amodeCode target (CIntLike x) =
- StPrim IntAddOp [intLikePtr, off]
- where off = StPrim IntMulOp [amodeCode target x,
- StInt (toInteger (intLikeClosureSize target))]
+amodeToStix (CReg magic) = StReg (StixMagicId magic)
+amodeToStix (CTemp uniq pk) = StReg (StixTemp uniq pk)
--- A CString is just a (CLit . MachStr)
-amodeCode target (CString s) = StString s
+amodeToStix (CLbl lbl _) = StCLbl lbl
-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"
+ -- For CharLike and IntLike, we attempt some trivial constant-folding here.
--- A CLitLit is just a (CLit . MachLitLit)
-amodeCode target (CLitLit s _) = StLitLit s
-
--- COffsets are in words, not bytes!
-amodeCode target (COffset off) = StInt (toInteger (hpRel target off))
+amodeToStix (CCharLike (CLit (MachChar c)))
+ = StIndex CharRep cHARLIKE_closure (StInt (toInteger off))
+ where
+ off = charLikeSize * ord c
-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]
+amodeToStix (CCharLike x)
+ = StIndex CharRep cHARLIKE_closure off
where
- tag = StInd IntKind (StIndex IntKind (amodeToStix target arg) (StInt (-2)))
- -- That ``-2'' really bothers me. (JSM)
+ off = StPrim IntMulOp [amodeToStix x, StInt (toInteger charLikeSize)]
-amodeCode target (CCostCentre cc print_as_string)
- = if noCostCentreAttached cc
- then StComment SLIT("") -- sigh
- else panic "amodeCode:CCostCentre"
+amodeToStix (CIntLike (CLit (MachInt i)))
+ = StIndex CharRep{-yes,really-} iNTLIKE_closure (StInt (toInteger off))
+ where
+ off = intLikeSize * (fromInteger (i - mIN_INTLIKE))
+
+amodeToStix (CIntLike x)
+ = panic "CIntLike"
+
+amodeToStix (CLit core)
+ = case core of
+ MachChar c -> StInt (toInteger (ord c))
+ MachStr s -> StString s
+ MachAddr a -> StInt a
+ MachInt i -> StInt i
+ MachWord w -> case word2IntLit core of MachInt iw -> StInt iw
+ MachLitLit s _ -> trace ("\nnativeGen WARNING: Reference to C entity `"
+ ++ (_UNPK_ s) ++ "' cannot be reliably compiled."
+ ++ "\n\t\t It may well crash your program."
+ ++ "\n\t\t Workaround: compile via C (use -fvia-C).\n"
+ )
+ (litLitToStix (_UNPK_ s))
+ MachFloat d -> StDouble d
+ MachDouble d -> StDouble d
+ _ -> panic "amodeToStix:core literal"
+
+amodeToStix (CLitLit s _)
+ = litLitToStix (_UNPK_ s)
+
+amodeToStix (CMacroExpr _ macro [arg])
+ = case macro of
+ ENTRY_CODE -> amodeToStix arg
+ ARG_TAG -> amodeToStix arg -- just an integer no. of words
+ GET_TAG ->
+#ifdef WORDS_BIGENDIAN
+ StPrim AndOp
+ [StInd WordRep (StIndex PtrRep (amodeToStix arg)
+ (StInt (toInteger (-1)))),
+ StInt 65535]
+#else
+ StPrim SrlOp
+ [StInd WordRep (StIndex PtrRep (amodeToStix arg)
+ (StInt (toInteger (-1)))),
+ StInt 16]
+#endif
+ UPD_FRAME_UPDATEE
+ -> StInd PtrRep (StIndex PtrRep (amodeToStix arg)
+ (StInt (toInteger uF_UPDATEE)))
+litLitToStix nm
+ | all is_id nm = StCLbl (mkForeignLabel (_PK_ nm) False{-ToDo: dynamic-})
+ | otherwise = error ("\nlitLitToStix: can't handle `" ++ nm ++ "'\n"
+ ++ "suggested workaround: use flag -fvia-C\n")
+
+ where is_id c = isAlpha c || isDigit c || c == '_'
\end{code}
-Sizes of the CharLike and IntLike closures that are arranged as arrays in the
-data segment. (These are in bytes.)
+Sizes of the CharLike and IntLike closures that are arranged as arrays
+in the data segment. (These are in bytes.)
\begin{code}
-
-- The INTLIKE base pointer
-intLikePtr :: StixTree
-
-intLikePtr = StInd PtrKind (sStLitLbl SLIT("INTLIKE_closures"))
+iNTLIKE_closure :: StixTree
+iNTLIKE_closure = StCLbl mkIntlikeClosureLabel
-- The CHARLIKE base
-charLike :: StixTree
-
-charLike = sStLitLbl SLIT("CHARLIKE_closures")
+cHARLIKE_closure :: StixTree
+cHARLIKE_closure = StCLbl mkCharlikeClosureLabel
-- Trees for the ErrorIOPrimOp
-topClosure, flushStdout, flushStderr, errorIO :: StixTree
+topClosure, errorIO :: StixTree
+
+topClosure = StInd PtrRep (StCLbl mkTopClosureLabel)
+errorIO = StJump (StInd PtrRep (StCLbl mkErrorIO_innardsLabel))
-topClosure = StInd PtrKind (sStLitLbl SLIT("TopClosure"))
-flushStdout = StCall SLIT("fflush") VoidKind [StLitLit SLIT("stdout")]
-flushStderr = StCall SLIT("fflush") VoidKind [StLitLit SLIT("stderr")]
-errorIO = StJump (StInd PtrKind (sStLitLbl SLIT("ErrorIO_innards")))
+mutArrPtrsFrozen_info = StCLbl mkMAP_FROZEN_infoLabel
+-- these are the sizes of charLike and intLike closures, in _bytes_.
+charLikeSize = (fixedHdrSize + 1) * (fromInteger (sizeOf PtrRep))
+intLikeSize = (fixedHdrSize + 1) * (fromInteger (sizeOf PtrRep))
\end{code}
+
+\begin{code}
+save_thread_state
+ = getUniqueUs `thenUs` \tso_uq ->
+ let tso = StReg (StixTemp tso_uq ThreadIdRep) in
+ returnUs (\xs ->
+ StAssign ThreadIdRep tso stgCurrentTSO :
+ StAssign PtrRep
+ (StInd PtrRep (StPrim IntAddOp
+ [tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))]))
+ stgSp :
+ StAssign PtrRep
+ (StInd PtrRep (StPrim IntAddOp
+ [tso, StInt (toInteger (TSO_SU*BYTES_PER_WORD))]))
+ stgSu :
+ StAssign PtrRep
+ (StInd PtrRep (StPrim IntAddOp
+ [tso, StInt (toInteger (TSO_SPLIM*BYTES_PER_WORD))]))
+ stgSpLim :
+ StAssign PtrRep
+ (StInd PtrRep (StPrim IntAddOp
+ [stgCurrentNursery,
+ StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))]))
+ (StPrim IntAddOp [stgHp, StInt (toInteger (1 * BYTES_PER_WORD))]) :
+ xs
+ )
+
+load_thread_state
+ = getUniqueUs `thenUs` \tso_uq ->
+ let tso = StReg (StixTemp tso_uq ThreadIdRep) in
+ returnUs (\xs ->
+ StAssign ThreadIdRep tso stgCurrentTSO :
+ StAssign PtrRep stgSp
+ (StInd PtrRep (StPrim IntAddOp
+ [tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))])) :
+ StAssign PtrRep stgSu
+ (StInd PtrRep (StPrim IntAddOp
+ [tso, StInt (toInteger (TSO_SU*BYTES_PER_WORD))])) :
+ StAssign PtrRep stgSpLim
+ (StInd PtrRep (StPrim IntAddOp
+ [tso, StInt (toInteger (TSO_SPLIM*BYTES_PER_WORD))])) :
+ StAssign PtrRep stgHp
+ (StPrim IntSubOp [
+ StInd PtrRep (StPrim IntAddOp
+ [stgCurrentNursery,
+ StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))]),
+ StInt (toInteger (1 * BYTES_PER_WORD))
+ ]) :
+ StAssign PtrRep stgHpLim
+ (StPrim IntAddOp [
+ StInd PtrRep (StPrim IntAddOp
+ [stgCurrentNursery,
+ StInt (toInteger (BDESCR_START * BYTES_PER_WORD))]),
+ StInt (toInteger (bLOCK_SIZE - (1 * BYTES_PER_WORD)))
+ ]) :
+ xs
+ )
+\end{code}
projects / ghc-hetmet.git / blobdiff