X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FnativeGen%2FStixPrim.lhs;h=d8c9e9783fdedc01711daa9618c8be214f6df1f1;hb=6246213687602d5bd9b4f12026fd300dfa4b4afd;hp=40c1a3a87838d9359de9e7b223bce6a583b5fff9;hpb=10521d8418fd3a1cf32882718b5bd28992db36fd;p=ghc-hetmet.git diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs index 40c1a3a..d8c9e97 100644 --- a/ghc/compiler/nativeGen/StixPrim.lhs +++ b/ghc/compiler/nativeGen/StixPrim.lhs @@ -1,631 +1,751 @@ % -% (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 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 PrimOp ( PrimOp(..), CCall(..), CCallTarget(..) ) +import PrimRep ( PrimRep(..), getPrimRepSizeInBytes ) +import UniqSupply ( returnUs, thenUs, getUniqueUs, UniqSM ) +import Constants ( mIN_INTLIKE, mIN_CHARLIKE, uF_UPDATEE, bLOCK_SIZE, + rESERVED_STACK_WORDS ) +import CLabel ( mkIntlikeClosureLabel, mkCharlikeClosureLabel, + mkMAP_FROZEN_infoLabel, mkEMPTY_MVAR_infoLabel, + mkForeignLabel ) +import CallConv ( cCallConv ) +import Outputable +import FastTypes + +#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 +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} --- hacking with Uncle Will: -#define target_STRICT target@(Target _ _ _ _ _ _ _ _) - -genPrimCode target_STRICT res op args - = genprim res op args - where - a2stix = amodeToStix target - a2stix' = amodeToStix' target - mut_hs = mutHS target - data_hs = dataHS target - heap_chkr = heapCheck target - size_of = sizeof target - fixed_hs = fixedHeaderSize target - var_hs = varHeaderSize target - - --- real code will follow... ------------- -\end{code} +-- NB: ordering of clauses somewhere driven by +-- the desire to getting sane patt-matching behavior -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] IntegerCmpOp args@[sa1,da1, sa2,da2] + = gmpCompare res (sa1,da1, sa2,da2) -\begin{code} - -- NB: ordering of clauses somewhere driven by - -- the desire to getting sane patt-matching behavior - - genprim res@[ar1,sr1,dr1, ar2,sr2,dr2] - IntegerQuotRemOp - args@[liveness, aa1,sa1,da1, aa2,sa2,da2] = - gmpTake2Return2 target (ar1,sr1,dr1, ar2,sr2,dr2) SLIT("mpz_divmod") (liveness, aa1,sa1,da1, aa2,sa2,da2) - - genprim res@[ar1,sr1,dr1, ar2,sr2,dr2] - IntegerDivModOp - args@[liveness, aa1,sa1,da1, aa2,sa2,da2] = - gmpTake2Return2 target (ar1,sr1,dr1, ar2,sr2,dr2) SLIT("mpz_targetivmod") (liveness, aa1,sa1,da1, aa2,sa2,da2) - - genprim res@[ar,sr,dr] IntegerAddOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2] = - gmpTake2Return1 target (ar,sr,dr) SLIT("mpz_add") (liveness, aa1,sa1,da1, aa2,sa2,da2) - genprim res@[ar,sr,dr] IntegerSubOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2] = - gmpTake2Return1 target (ar,sr,dr) SLIT("mpz_sub") (liveness, aa1,sa1,da1, aa2,sa2,da2) - genprim res@[ar,sr,dr] IntegerMulOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2] = - gmpTake2Return1 target (ar,sr,dr) SLIT("mpz_mul") (liveness, aa1,sa1,da1, aa2,sa2,da2) - - genprim res@[ar,sr,dr] IntegerNegOp arg@[liveness,aa,sa,da] = - gmpTake1Return1 target (ar,sr,dr) SLIT("mpz_neg") (liveness,aa,sa,da) -\end{code} +primCode [res] IntegerCmpIntOp args@[sa1,da1,ai] + = gmpCompareInt res (sa1,da1,ai) -Since we are using the heap for intermediate @MP_INT@ structs, integer comparison -{\em does} require a heap check in the native code implementation. +primCode [res] Integer2IntOp arg@[sa,da] + = gmpInteger2Int res (sa,da) -\begin{code} - genprim res@[exponr,ar,sr,dr] FloatDecodeOp args@[hp, arg] = - decodeFloatingKind FloatKind target (exponr,ar,sr,dr) (hp, arg) +primCode [res] Integer2WordOp arg@[sa,da] + = gmpInteger2Word res (sa,da) - genprim res@[exponr,ar,sr,dr] DoubleDecodeOp args@[hp, arg] = - decodeFloatingKind DoubleKind target (exponr,ar,sr,dr) (hp, arg) +primCode [res] Int2AddrOp [arg] + = simpleCoercion AddrRep res arg - genprim res@[ar,sr,dr] Int2IntegerOp args@[hp, n] - = gmpInt2Integer target (ar,sr,dr) (hp, n) +primCode [res] Addr2IntOp [arg] + = simpleCoercion IntRep res arg - genprim res@[ar,sr,dr] Addr2IntegerOp args@[liveness,str] - = gmpString2Integer target (ar,sr,dr) (liveness,str) +primCode [res] Int2WordOp [arg] + = simpleCoercion IntRep{-WordRep?-} res arg - genprim [res] IntegerCmpOp args@[hp, aa1,sa1,da1, aa2,sa2,da2] - = gmpCompare target res (hp, aa1,sa1,da1, aa2,sa2,da2) +primCode [res] Word2IntOp [arg] + = simpleCoercion IntRep res arg - genprim [res] Integer2IntOp arg@[hp, aa,sa,da] - = gmpInteger2Int target res (hp, aa,sa,da) +primCode [res] AddrToHValueOp [arg] + = simpleCoercion PtrRep res arg - genprim [res] FloatEncodeOp args@[hp, aa,sa,da, expon] = - encodeFloatingKind FloatKind target res (hp, aa,sa,da, expon) +primCode [res] IntToInt8Op [arg] + = narrowingCoercion IntRep Int8Rep res arg +primCode [res] IntToInt16Op [arg] + = narrowingCoercion IntRep Int16Rep res arg +primCode [res] IntToInt32Op [arg] + = narrowingCoercion IntRep Int32Rep res arg - genprim [res] DoubleEncodeOp args@[hp, aa,sa,da, expon] = - encodeFloatingKind DoubleKind target res (hp, aa,sa,da, expon) +primCode [res] WordToWord8Op [arg] + = narrowingCoercion WordRep Word8Rep res arg +primCode [res] WordToWord16Op [arg] + = narrowingCoercion WordRep Word16Rep res arg +primCode [res] WordToWord32Op [arg] + = narrowingCoercion WordRep Word32Rep res arg +\end{code} - genprim [res] Int2AddrOp [arg] = - simpleCoercion AddrKind res arg +\begin{code} +primCode [res] SameMutableArrayOp args + = let + compare = StPrim AddrEqOp (map amodeToStix args) + assign = StAssign IntRep (amodeToStix res) compare + in + returnUs (\xs -> assign : xs) - genprim [res] Addr2IntOp [arg] = - simpleCoercion IntKind res arg +primCode res@[_] SameMutableByteArrayOp args + = primCode res SameMutableArrayOp args - genprim [res] Int2WordOp [arg] = - simpleCoercion IntKind{-WordKind?-} res arg +primCode res@[_] SameMutVarOp args + = primCode res SameMutableArrayOp args +\end{code} - genprim [res] Word2IntOp [arg] = - simpleCoercion IntKind res arg +\begin{code} +primCode res@[_] SameMVarOp args + = primCode res SameMutableArrayOp args + +-- #define isEmptyMVarzh(r,a) \ +-- r =(I_)((GET_INFO((StgMVar*)(a))) == &stg_EMPTY_MVAR_info ) +primCode [res] IsEmptyMVarOp [arg] + = let res' = amodeToStix res + arg' = amodeToStix arg + arg_info = StInd PtrRep arg' + em_info = StCLbl mkEMPTY_MVAR_infoLabel + same = StPrim IntEqOp [arg_info, em_info] + assign = StAssign IntRep res' same + in + returnUs (\xs -> assign : xs) + +-- #define myThreadIdzh(t) (t = CurrentTSO) +primCode [res] MyThreadIdOp [] + = let res' = amodeToStix res + in returnUs (\xs -> StAssign ThreadIdRep res' stgCurrentTSO : xs) \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@. +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} - genprim [] ErrorIOPrimOp [rhs] = - let changeTop = StAssign PtrKind topClosure (a2stix rhs) +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 -> changeTop : flushStdout : flushStderr : errorIO : xs) + returnUs (\xs -> assign : freeze : xs) +primCode [lhs] UnsafeFreezeByteArrayOp [rhs] + = simpleCoercion PtrRep lhs rhs \end{code} -@newArray#@ ops allocate heap space. +Returning the size of (mutable) byte arrays is just +an indexing operation. \begin{code} - genprim [res] NewArrayOp args = - let [liveness, n, initial] = map a2stix args - result = a2stix res - space = StPrim IntAddOp [n, mut_hs] - 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] +primCode [lhs] SizeofByteArrayOp [rhs] + = let + lhs' = amodeToStix lhs + rhs' = amodeToStix rhs + sz = StIndex IntRep rhs' fixedHS + assign = StAssign IntRep lhs' (StInd IntRep sz) in - heap_chkr liveness space (StInt 0) `thenSUs` \ heap_chk -> - - returnSUs (heap_chk . (\xs -> assign : initialise : xs)) - - genprim [res] (NewByteArrayOp pk) args = - let [liveness, count] = map a2stix args - result = a2stix res - n = StPrim IntMulOp [count, StInt (toInteger (size_of pk))] - slop = StPrim IntAddOp [n, StInt (toInteger (size_of IntKind - 1))] - words = StPrim IntQuotOp [slop, StInt (toInteger (size_of IntKind))] - space = StPrim IntAddOp [n, StPrim IntAddOp [words, data_hs]] - 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 fixed_hs)))) - (StPrim IntAddOp [words, - StInt (toInteger (var_hs (DataRep 0)))]) + 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 - heap_chkr liveness space (StInt 0) `thenSUs` \ heap_chk -> + returnUs (\xs -> assign : xs) + +\end{code} - returnSUs (heap_chk . (\xs -> assign : init1 : init2 : xs)) +Most other array primitives translate to simple indexing. - genprim [res] SameMutableArrayOp args = - let compare = StPrim AddrEqOp (map a2stix args) - assign = StAssign IntKind (a2stix res) compare +\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 - returnSUs (\xs -> assign : xs) + 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) - genprim res@[_] SameMutableByteArrayOp args = - genprim res SameMutableArrayOp args +-- NB: indexing in "pk" units, *not* in bytes (WDP 95/09) +primCode ls IndexByteArrayOp_Char rs = primCode_ReadByteArrayOp Word8Rep ls rs +primCode ls IndexByteArrayOp_WideChar rs = primCode_ReadByteArrayOp CharRep ls rs +primCode ls IndexByteArrayOp_Int rs = primCode_ReadByteArrayOp IntRep ls rs +primCode ls IndexByteArrayOp_Word rs = primCode_ReadByteArrayOp WordRep ls rs +primCode ls IndexByteArrayOp_Addr rs = primCode_ReadByteArrayOp AddrRep ls rs +primCode ls IndexByteArrayOp_Float rs = primCode_ReadByteArrayOp FloatRep ls rs +primCode ls IndexByteArrayOp_Double rs = primCode_ReadByteArrayOp DoubleRep ls rs +primCode ls IndexByteArrayOp_StablePtr rs = primCode_ReadByteArrayOp StablePtrRep ls rs +primCode ls IndexByteArrayOp_Int8 rs = primCode_ReadByteArrayOp Int8Rep ls rs +primCode ls IndexByteArrayOp_Int16 rs = primCode_ReadByteArrayOp Int16Rep ls rs +primCode ls IndexByteArrayOp_Int32 rs = primCode_ReadByteArrayOp Int32Rep ls rs +primCode ls IndexByteArrayOp_Int64 rs = primCode_ReadByteArrayOp Int64Rep ls rs +primCode ls IndexByteArrayOp_Word8 rs = primCode_ReadByteArrayOp Word8Rep ls rs +primCode ls IndexByteArrayOp_Word16 rs = primCode_ReadByteArrayOp Word16Rep ls rs +primCode ls IndexByteArrayOp_Word32 rs = primCode_ReadByteArrayOp Word32Rep ls rs +primCode ls IndexByteArrayOp_Word64 rs = primCode_ReadByteArrayOp Word64Rep ls rs + +primCode ls ReadByteArrayOp_Char rs = primCode_ReadByteArrayOp Word8Rep ls rs +primCode ls ReadByteArrayOp_WideChar rs = primCode_ReadByteArrayOp CharRep ls rs +primCode ls ReadByteArrayOp_Int rs = primCode_ReadByteArrayOp IntRep ls rs +primCode ls ReadByteArrayOp_Word rs = primCode_ReadByteArrayOp WordRep ls rs +primCode ls ReadByteArrayOp_Addr rs = primCode_ReadByteArrayOp AddrRep ls rs +primCode ls ReadByteArrayOp_Float rs = primCode_ReadByteArrayOp FloatRep ls rs +primCode ls ReadByteArrayOp_Double rs = primCode_ReadByteArrayOp DoubleRep ls rs +primCode ls ReadByteArrayOp_StablePtr rs = primCode_ReadByteArrayOp StablePtrRep ls rs +primCode ls ReadByteArrayOp_Int8 rs = primCode_ReadByteArrayOp Int8Rep ls rs +primCode ls ReadByteArrayOp_Int16 rs = primCode_ReadByteArrayOp Int16Rep ls rs +primCode ls ReadByteArrayOp_Int32 rs = primCode_ReadByteArrayOp Int32Rep ls rs +primCode ls ReadByteArrayOp_Int64 rs = primCode_ReadByteArrayOp Int64Rep ls rs +primCode ls ReadByteArrayOp_Word8 rs = primCode_ReadByteArrayOp Word8Rep ls rs +primCode ls ReadByteArrayOp_Word16 rs = primCode_ReadByteArrayOp Word16Rep ls rs +primCode ls ReadByteArrayOp_Word32 rs = primCode_ReadByteArrayOp Word32Rep ls rs +primCode ls ReadByteArrayOp_Word64 rs = primCode_ReadByteArrayOp Word64Rep ls rs + +primCode ls WriteByteArrayOp_Char rs = primCode_WriteByteArrayOp Word8Rep ls rs +primCode ls WriteByteArrayOp_WideChar rs = primCode_WriteByteArrayOp CharRep ls rs +primCode ls WriteByteArrayOp_Int rs = primCode_WriteByteArrayOp IntRep ls rs +primCode ls WriteByteArrayOp_Word rs = primCode_WriteByteArrayOp WordRep ls rs +primCode ls WriteByteArrayOp_Addr rs = primCode_WriteByteArrayOp AddrRep ls rs +primCode ls WriteByteArrayOp_Float rs = primCode_WriteByteArrayOp FloatRep ls rs +primCode ls WriteByteArrayOp_Double rs = primCode_WriteByteArrayOp DoubleRep ls rs +primCode ls WriteByteArrayOp_StablePtr rs = primCode_WriteByteArrayOp StablePtrRep ls rs +primCode ls WriteByteArrayOp_Int8 rs = primCode_WriteByteArrayOp Int8Rep ls rs +primCode ls WriteByteArrayOp_Int16 rs = primCode_WriteByteArrayOp Int16Rep ls rs +primCode ls WriteByteArrayOp_Int32 rs = primCode_WriteByteArrayOp Int32Rep ls rs +primCode ls WriteByteArrayOp_Int64 rs = primCode_WriteByteArrayOp Int64Rep ls rs +primCode ls WriteByteArrayOp_Word8 rs = primCode_WriteByteArrayOp Word8Rep ls rs +primCode ls WriteByteArrayOp_Word16 rs = primCode_WriteByteArrayOp Word16Rep ls rs +primCode ls WriteByteArrayOp_Word32 rs = primCode_WriteByteArrayOp Word32Rep ls rs +primCode ls WriteByteArrayOp_Word64 rs = primCode_WriteByteArrayOp Word64Rep ls rs + +primCode ls IndexOffAddrOp_Char rs = primCode_IndexOffAddrOp Word8Rep ls rs +primCode ls IndexOffAddrOp_WideChar rs = primCode_IndexOffAddrOp CharRep ls rs +primCode ls IndexOffAddrOp_Int rs = primCode_IndexOffAddrOp IntRep ls rs +primCode ls IndexOffAddrOp_Word rs = primCode_IndexOffAddrOp WordRep ls rs +primCode ls IndexOffAddrOp_Addr rs = primCode_IndexOffAddrOp AddrRep ls rs +primCode ls IndexOffAddrOp_Float rs = primCode_IndexOffAddrOp FloatRep ls rs +primCode ls IndexOffAddrOp_Double rs = primCode_IndexOffAddrOp DoubleRep ls rs +primCode ls IndexOffAddrOp_StablePtr rs = primCode_IndexOffAddrOp StablePtrRep ls rs +primCode ls IndexOffAddrOp_Int8 rs = primCode_IndexOffAddrOp Int8Rep ls rs +primCode ls IndexOffAddrOp_Int16 rs = primCode_IndexOffAddrOp Int16Rep ls rs +primCode ls IndexOffAddrOp_Int32 rs = primCode_IndexOffAddrOp Int32Rep ls rs +primCode ls IndexOffAddrOp_Int64 rs = primCode_IndexOffAddrOp Int64Rep ls rs +primCode ls IndexOffAddrOp_Word8 rs = primCode_IndexOffAddrOp Word8Rep ls rs +primCode ls IndexOffAddrOp_Word16 rs = primCode_IndexOffAddrOp Word16Rep ls rs +primCode ls IndexOffAddrOp_Word32 rs = primCode_IndexOffAddrOp Word32Rep ls rs +primCode ls IndexOffAddrOp_Word64 rs = primCode_IndexOffAddrOp Word64Rep ls rs + +primCode ls IndexOffForeignObjOp_Char rs = primCode_IndexOffForeignObjOp Word8Rep ls rs +primCode ls IndexOffForeignObjOp_WideChar rs = primCode_IndexOffForeignObjOp CharRep ls rs +primCode ls IndexOffForeignObjOp_Int rs = primCode_IndexOffForeignObjOp IntRep ls rs +primCode ls IndexOffForeignObjOp_Word rs = primCode_IndexOffForeignObjOp WordRep ls rs +primCode ls IndexOffForeignObjOp_Addr rs = primCode_IndexOffForeignObjOp AddrRep ls rs +primCode ls IndexOffForeignObjOp_Float rs = primCode_IndexOffForeignObjOp FloatRep ls rs +primCode ls IndexOffForeignObjOp_Double rs = primCode_IndexOffForeignObjOp DoubleRep ls rs +primCode ls IndexOffForeignObjOp_StablePtr rs = primCode_IndexOffForeignObjOp StablePtrRep ls rs +primCode ls IndexOffForeignObjOp_Int8 rs = primCode_IndexOffForeignObjOp Int8Rep ls rs +primCode ls IndexOffForeignObjOp_Int16 rs = primCode_IndexOffForeignObjOp Int16Rep ls rs +primCode ls IndexOffForeignObjOp_Int32 rs = primCode_IndexOffForeignObjOp Int32Rep ls rs +primCode ls IndexOffForeignObjOp_Int64 rs = primCode_IndexOffForeignObjOp Int64Rep ls rs +primCode ls IndexOffForeignObjOp_Word8 rs = primCode_IndexOffForeignObjOp Word8Rep ls rs +primCode ls IndexOffForeignObjOp_Word16 rs = primCode_IndexOffForeignObjOp Word16Rep ls rs +primCode ls IndexOffForeignObjOp_Word32 rs = primCode_IndexOffForeignObjOp Word32Rep ls rs +primCode ls IndexOffForeignObjOp_Word64 rs = primCode_IndexOffForeignObjOp Word64Rep ls rs + +primCode ls ReadOffAddrOp_Char rs = primCode_IndexOffAddrOp Word8Rep ls rs +primCode ls ReadOffAddrOp_WideChar rs = primCode_IndexOffAddrOp CharRep ls rs +primCode ls ReadOffAddrOp_Int rs = primCode_IndexOffAddrOp IntRep ls rs +primCode ls ReadOffAddrOp_Word rs = primCode_IndexOffAddrOp WordRep ls rs +primCode ls ReadOffAddrOp_Addr rs = primCode_IndexOffAddrOp AddrRep ls rs +primCode ls ReadOffAddrOp_Float rs = primCode_IndexOffAddrOp FloatRep ls rs +primCode ls ReadOffAddrOp_Double rs = primCode_IndexOffAddrOp DoubleRep ls rs +primCode ls ReadOffAddrOp_StablePtr rs = primCode_IndexOffAddrOp StablePtrRep ls rs +primCode ls ReadOffAddrOp_Int8 rs = primCode_IndexOffAddrOp Int8Rep ls rs +primCode ls ReadOffAddrOp_Int16 rs = primCode_IndexOffAddrOp Int16Rep ls rs +primCode ls ReadOffAddrOp_Int32 rs = primCode_IndexOffAddrOp Int32Rep ls rs +primCode ls ReadOffAddrOp_Int64 rs = primCode_IndexOffAddrOp Int64Rep ls rs +primCode ls ReadOffAddrOp_Word8 rs = primCode_IndexOffAddrOp Word8Rep ls rs +primCode ls ReadOffAddrOp_Word16 rs = primCode_IndexOffAddrOp Word16Rep ls rs +primCode ls ReadOffAddrOp_Word32 rs = primCode_IndexOffAddrOp Word32Rep ls rs +primCode ls ReadOffAddrOp_Word64 rs = primCode_IndexOffAddrOp Word64Rep ls rs + +primCode ls WriteOffAddrOp_Char rs = primCode_WriteOffAddrOp Word8Rep ls rs +primCode ls WriteOffAddrOp_WideChar rs = primCode_WriteOffAddrOp CharRep ls rs +primCode ls WriteOffAddrOp_Int rs = primCode_WriteOffAddrOp IntRep ls rs +primCode ls WriteOffAddrOp_Word rs = primCode_WriteOffAddrOp WordRep ls rs +primCode ls WriteOffAddrOp_Addr rs = primCode_WriteOffAddrOp AddrRep ls rs +primCode ls WriteOffAddrOp_Float rs = primCode_WriteOffAddrOp FloatRep ls rs +primCode ls WriteOffAddrOp_Double rs = primCode_WriteOffAddrOp DoubleRep ls rs +primCode ls WriteOffAddrOp_StablePtr rs = primCode_WriteOffAddrOp StablePtrRep ls rs +primCode ls WriteOffAddrOp_Int8 rs = primCode_WriteOffAddrOp Int8Rep ls rs +primCode ls WriteOffAddrOp_Int16 rs = primCode_WriteOffAddrOp Int16Rep ls rs +primCode ls WriteOffAddrOp_Int32 rs = primCode_WriteOffAddrOp Int32Rep ls rs +primCode ls WriteOffAddrOp_Int64 rs = primCode_WriteOffAddrOp Int64Rep ls rs +primCode ls WriteOffAddrOp_Word8 rs = primCode_WriteOffAddrOp Word8Rep ls rs +primCode ls WriteOffAddrOp_Word16 rs = primCode_WriteOffAddrOp Word16Rep ls rs +primCode ls WriteOffAddrOp_Word32 rs = primCode_WriteOffAddrOp Word32Rep ls rs +primCode ls WriteOffAddrOp_Word64 rs = primCode_WriteOffAddrOp Word64Rep ls rs \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). +ToDo: saving/restoring of volatile regs around ccalls. + +JRS, 001113: always do the call of suspendThread and resumeThread as a ccall +rather than inheriting the calling convention of the thing which we're really +calling. \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") {-no:cconv-} cCallConv + IntRep [stgBaseReg]) + resume = StCall SLIT("resumeThread") {-no:cconv-} cCallConv + VoidRep [id] + in + returnUs (\xs -> save (suspend : ccall : resume : load 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 -> StInd PtrRep (StIndex PtrRep base fixedHS) + _ -> base + + ccall = case lhs of + [] -> StCall fn cconv VoidRep args + [lhs] -> + let lhs' = amodeToStix lhs + pk = case getAmodeRep lhs of + FloatRep -> FloatRep + DoubleRep -> DoubleRep + other -> IntRep + in + StAssign pk lhs' (StCall fn cconv pk args) +\end{code} - genprim [lhs] UnsafeFreezeArrayOp [rhs] = - let lhs' = a2stix lhs - rhs' = a2stix rhs - header = StInd PtrKind lhs' - assign = StAssign PtrKind lhs' rhs' - freeze = StAssign PtrKind header imMutArrayOfPtrs_info +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 - returnSUs (\xs -> assign : freeze : xs) + returnUs (\xs -> assign : xs) +\end{code} - genprim [lhs] UnsafeFreezeByteArrayOp [rhs] = - simpleCoercion PtrKind lhs rhs +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} -Most other array primitives translate to simple indexing. +ForeignObj# primops. \begin{code} +primCode [rr] ForeignObjToAddrOp [fo] + = let code = StAssign AddrRep (amodeToStix rr) + (StInd AddrRep + (StIndex PtrRep (amodeToStix fo) fixedHS)) + in + returnUs (\xs -> code : xs) - genprim lhs@[_] IndexArrayOp args = - genprim lhs ReadArrayOp args +primCode [] TouchOp [_] = returnUs id +\end{code} - genprim [lhs] ReadArrayOp [obj, ix] = - let lhs' = a2stix lhs - obj' = a2stix obj - ix' = a2stix ix - base = StIndex IntKind obj' mut_hs - assign = StAssign PtrKind lhs' (StInd PtrKind (StIndex PtrKind base ix')) - in - returnSUs (\xs -> assign : xs) - - genprim [lhs] WriteArrayOp [obj, ix, v] = - let obj' = a2stix obj - ix' = a2stix ix - v' = a2stix v - base = StIndex IntKind obj' mut_hs - assign = StAssign PtrKind (StInd PtrKind (StIndex PtrKind base ix')) v' - in - returnSUs (\xs -> assign : xs) +Now the more mundane operations. - genprim lhs@[_] (IndexByteArrayOp pk) args = - genprim lhs (ReadByteArrayOp pk) args +\begin{code} +primCode lhs op rhs + = let + lhs' = map amodeToStix lhs + rhs' = map amodeToStix' rhs + pk = getAmodeRep (head lhs) + in + returnUs (\ xs -> simplePrim pk lhs' op rhs' : xs) +\end{code} --- NB: indexing in "pk" units, *not* in bytes (WDP 95/09) +Helper fns for some array ops. - genprim [lhs] (ReadByteArrayOp pk) [obj, ix] = - let lhs' = a2stix lhs - obj' = a2stix obj - ix' = a2stix ix - base = StIndex IntKind obj' data_hs +\begin{code} +primCode_ReadByteArrayOp pk [lhs] [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) - genprim [lhs] (IndexOffAddrOp pk) [obj, ix] = - let lhs' = a2stix lhs - obj' = a2stix obj - ix' = a2stix ix + +primCode_IndexOffAddrOp pk [lhs] [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) + returnUs (\xs -> assign : xs) - genprim [] (WriteByteArrayOp pk) [obj, ix, v] = - let obj' = a2stix obj - ix' = a2stix ix - v' = a2stix v - base = StIndex IntKind obj' data_hs - assign = StAssign pk (StInd pk (StIndex pk base ix')) v' - in - returnSUs (\xs -> assign : xs) -\end{code} -Stable pointer operations. - -First the easy one. +primCode_IndexOffForeignObjOp pk [lhs] [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 + returnUs (\xs -> assign : xs) -\begin{code} - genprim [lhs] DeRefStablePtrOp [sp] = - let lhs' = a2stix lhs - pk = getAmodeKind lhs - sp' = a2stix sp - call = StCall SLIT("deRefStablePointer") pk [sp', smStablePtrTable] - assign = StAssign pk lhs' call +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) -\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} - genprim [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] - ] - +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 - getUniqLabelCTS `thenCTS` \ oklbl -> - returnCodes sty md - (spt_EMPTY spt oklbl : (enlarge ++ (trLabel [oklbl] : allocate))) -\end{pseudocode} - -\begin{code} - genprim res Word2IntegerOp args = panic "genPrimCode:Word2IntegerOp" - - genprim 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' = a2stix 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 = a2stix' x - in - case getAmodeKind x of - ArrayKind -> StIndex PtrKind base mut_hs - ByteArrayKind -> StIndex IntKind base data_hs - MallocPtrKind -> error "ERROR: native-code generator can't handle Malloc Ptrs (yet): use -fvia-C!" - _ -> base -\end{code} + returnUs (\xs -> assign : xs) -Now the more mundane operations. +\end{code} \begin{code} - genprim lhs op rhs = - let lhs' = map a2stix lhs - rhs' = map a2stix' rhs - in - returnSUs (\ xs -> simplePrim lhs' op rhs' : xs) - - {- - simpleCoercion - :: Target - -> PrimKind - -> [CAddrMode] - -> [CAddrMode] - -> SUniqSM StixTreeList - -} - simpleCoercion pk lhs rhs = - returnSUs (\xs -> StAssign pk (a2stix lhs) (a2stix rhs) : xs) - +simpleCoercion + :: PrimRep + -> CAddrMode + -> CAddrMode + -> UniqSM StixTreeList + +simpleCoercion pk lhs rhs + = returnUs (\xs -> StAssign pk (amodeToStix lhs) (amodeToStix rhs) : xs) + + +-- Rewrite a narrowing coercion into a pair of shifts. +narrowingCoercion + :: PrimRep -> PrimRep + -> CAddrMode -> CAddrMode + -> UniqSM StixTreeList + +narrowingCoercion pks pkd dst src + | szd > szs + = panic "StixPrim.narrowingCoercion" + | szd == szs + = returnUs (\xs -> StAssign pkd dst' src' : xs) + | otherwise + = returnUs (\xs -> assign : xs) + where + szs = getPrimRepSizeInBytes pks + szd = getPrimRepSizeInBytes pkd + src' = amodeToStix src + dst' = amodeToStix dst + shift_amt = fromIntegral (8 * (szs - szd)) + + assign + = StAssign pkd dst' + (StPrim (if signed then ISraOp else SrlOp) + [StPrim SllOp [src', StInt shift_amt], + StInt shift_amt]) + signed + = case pkd of + Int8Rep -> True; Int16Rep -> True + Int32Rep -> True; Int64Rep -> True; IntRep -> True + Word8Rep -> False; Word16Rep -> False + Word32Rep -> False; Word64Rep -> False; WordRep -> False + other -> pprPanic "StixPrim.narrowingCoercion" (ppr pkd) \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 pk [lhs] op rest = StAssign pk lhs (StPrim op rest) +simplePrim pk as op bs = simplePrim_error op - simplePrim [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 _ op _ = 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") +simplePrim_error op + = 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_STRICT am@(CVal rr CharKind) - | mixedTypeLocn am = StPrim ChrOp [amodeToStix target am] - | otherwise = amodeToStix target am - -amodeCode' target am = amodeToStix target am +amodeToStix'{-'-} am@(CVal rr CharRep) + | mixedTypeLocn am = StPrim ChrOp [amodeToStix am] + | otherwise = amodeToStix am -amodeCode target_STRICT am - = acode am - where - -- grab "target" things: - hp_rel = hpRel target - char_like = charLikeClosureSize target - int_like = intLikeClosureSize target - a2stix = amodeToStix target +amodeToStix' am = amodeToStix am - -- real code: ---------------------------------- - acode am@(CVal rr CharKind) | mixedTypeLocn am = - StInd IntKind (acode (CAddr rr)) +----------- +amodeToStix am@(CVal rr CharRep) + | mixedTypeLocn am + = StInd IntRep (amodeToStix (CAddr rr)) - acode (CVal rr pk) = StInd pk (acode (CAddr rr)) +amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr)) - acode (CAddr r@(SpARel spA off)) = - StIndex PtrKind stgSpA (StInt (toInteger (spARelToInt r))) +amodeToStix (CAddr (SpRel off)) + = StIndex PtrRep stgSp (StInt (toInteger (iBox off))) - acode (CAddr r@(SpBRel spB off)) = - StIndex IntKind stgSpB (StInt (toInteger (spBRelToInt r))) +amodeToStix (CAddr (HpRel off)) + = StIndex IntRep stgHp (StInt (toInteger (- (iBox off)))) - acode (CAddr (HpRel hp off)) = - StIndex IntKind stgHp (StInt (toInteger (-(hp_rel (hp `subOff` off))))) +amodeToStix (CAddr (NodeRel off)) + = StIndex IntRep stgNode (StInt (toInteger (iBox off))) - acode (CAddr (NodeRel off)) = - StIndex IntKind stgNode (StInt (toInteger (hp_rel off))) +amodeToStix (CAddr (CIndex base off pk)) + = StIndex pk (amodeToStix base) (amodeToStix off) - acode (CReg magic) = StReg (StixMagicId magic) - acode (CTemp uniq pk) = StReg (StixTemp uniq pk) +amodeToStix (CReg magic) = StReg (StixMagicId magic) +amodeToStix (CTemp uniq pk) = StReg (StixTemp uniq pk) - acode (CLbl lbl _) = StCLbl lbl - - acode (CUnVecLbl dir _) = StCLbl dir - - acode (CTableEntry base off pk) = - StInd pk (StIndex pk (acode base) (acode off)) +amodeToStix (CLbl lbl _) = StCLbl lbl -- For CharLike and IntLike, we attempt some trivial constant-folding here. - acode (CCharLike (CLit (MachChar c))) = - StLitLbl (uppBeside (uppPStr SLIT("CHARLIKE_closures+")) (uppInt off)) - where off = char_like * ord c - - acode (CCharLike x) = - StPrim IntAddOp [charLike, off] - where off = StPrim IntMulOp [acode x, - StInt (toInteger (char_like))] - - acode (CIntLike (CLit (MachInt i _))) = - StPrim IntAddOp [intLikePtr, StInt off] - where off = toInteger int_like * i - - acode (CIntLike x) = - StPrim IntAddOp [intLikePtr, off] - where off = StPrim IntMulOp [acode x, - StInt (toInteger int_like)] - - -- A CString is just a (CLit . MachStr) - acode (CString s) = StString s - - acode (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" - - -- A CLitLit is just a (CLit . MachLitLit) - acode (CLitLit s _) = StLitLit s - - -- COffsets are in words, not bytes! - acode (COffset off) = StInt (toInteger (hp_rel off)) - - acode (CMacroExpr _ macro [arg]) = - case macro of - INFO_PTR -> StInd PtrKind (a2stix arg) - ENTRY_CODE -> a2stix arg - INFO_TAG -> tag - EVAL_TAG -> StPrim IntGeOp [tag, StInt 0] - where - tag = StInd IntKind (StIndex IntKind (a2stix arg) (StInt (-2))) - -- That ``-2'' really bothers me. (JSM) - - acode (CCostCentre cc print_as_string) - = if noCostCentreAttached cc - then StComment SLIT("") -- sigh - else panic "amodeCode:CCostCentre" +amodeToStix (CCharLike (CLit (MachChar c))) + = StIndex Word8Rep cHARLIKE_closure (StInt (toInteger off)) + where + off = charLikeSize * (c - mIN_CHARLIKE) + +amodeToStix (CCharLike x) + = panic "CCharLike" + +amodeToStix (CIntLike (CLit (MachInt i))) + = StIndex Word8Rep 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 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 _ -> litLitErr + MachLabel l -> StCLbl (mkForeignLabel l False{-ToDo: dynamic-}) + MachFloat d -> StFloat d + MachDouble d -> StDouble d + _ -> panic "amodeToStix:core literal" + +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))) + +litLitErr = + panic "native code generator can't compile lit-lits, use -fvia-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_closure :: StixTree +cHARLIKE_closure = StCLbl mkCharlikeClosureLabel -charLike = sStLitLbl SLIT("CHARLIKE_closures") +mutArrPtrsFrozen_info = StCLbl mkMAP_FROZEN_infoLabel --- Trees for the ErrorIOPrimOp - -topClosure, flushStdout, flushStderr, errorIO :: StixTree +-- these are the sizes of charLike and intLike closures, in _bytes_. +charLikeSize = (fixedHdrSize + 1) * (sizeOf PtrRep) +intLikeSize = (fixedHdrSize + 1) * (sizeOf PtrRep) +\end{code} -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"))) +\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 + [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 + (StPrim IntAddOp [tso, + StInt (toInteger ((TSO_STACK + rESERVED_STACK_WORDS) + *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} -