X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FnativeGen%2FStixPrim.lhs;h=8df78124b2c5c0ab947ec0addf95f3404a0295e9;hb=553e90d9a32ee1b1809430f260c401cc4169c6c7;hp=81778922dd67424f9d8de5c43cb7692edf86a030;hpb=6a3f5f6beed9cec42c4b3a1b7cabc1809c838562;p=ghc-hetmet.git diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs index 8177892..8df7812 100644 --- a/ghc/compiler/nativeGen/StixPrim.lhs +++ b/ghc/compiler/nativeGen/StixPrim.lhs @@ -3,470 +3,134 @@ % \begin{code} -module StixPrim ( primCode, amodeToStix, amodeToStix' ) where +module StixPrim ( amodeToStix, amodeToStix', foreignCallCode ) +where #include "HsVersions.h" -import MachMisc +-- import MachMisc import Stix -import StixInteger +import PprAbsC ( pprAmode ) import AbsCSyn hiding ( spRel ) import AbsCUtils ( getAmodeRep, mixedTypeLocn ) import SMRep ( fixedHdrSize ) import Literal ( Literal(..), word2IntLit ) -import PrimOp ( PrimOp(..), CCall(..), CCallTarget(..) ) -import PrimRep ( PrimRep(..), isFloatingRep ) +import MachOp ( MachOp(..) ) +import PrimRep ( PrimRep(..), getPrimRepSizeInBytes ) import UniqSupply ( returnUs, thenUs, getUniqueUs, UniqSM ) -import Constants ( mIN_INTLIKE, mIN_CHARLIKE, uF_UPDATEE, bLOCK_SIZE, +import Constants ( mIN_INTLIKE, mIN_CHARLIKE, bLOCK_SIZE, rESERVED_STACK_WORDS ) import CLabel ( mkIntlikeClosureLabel, mkCharlikeClosureLabel, - mkMAP_FROZEN_infoLabel, mkForeignLabel ) + mkForeignLabel ) +import ForeignCall ( ForeignCall(..), CCallSpec(..), CCallTarget(..), + CCallConv(..), playSafe, playThreadSafe ) import Outputable +import Util ( notNull ) +import FastString import FastTypes +import Char #include "NCG.h" \end{code} -The main honcho here is primCode, which handles the guts of COpStmts. +The main honchos here are primCode and foreignCallCode, which handle the guts of COpStmts. \begin{code} -primCode +foreignCallCode :: [CAddrMode] -- results - -> PrimOp -- op + -> ForeignCall -- op -> [CAddrMode] -- args - -> UniqSM StixTreeList + -> UniqSM StixStmtList \end{code} -First, the dreaded @ccall@. We can't handle @casm@s. +%************************************************************************ +%* * +\subsubsection{Code for foreign calls} +%* * +%************************************************************************ + +First, the dreaded @ccall@. 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} --- 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) - -primCode [res] IntegerCmpOp args@[sa1,da1, sa2,da2] - = gmpCompare res (sa1,da1, sa2,da2) - -primCode [res] IntegerCmpIntOp args@[sa1,da1,ai] - = gmpCompareInt res (sa1,da1,ai) - -primCode [res] Integer2IntOp arg@[sa,da] - = gmpInteger2Int res (sa,da) - -primCode [res] Integer2WordOp arg@[sa,da] - = gmpInteger2Word res (sa,da) - -primCode [res] Int2AddrOp [arg] - = simpleCoercion AddrRep res arg - -primCode [res] Addr2IntOp [arg] - = simpleCoercion IntRep res arg - -primCode [res] Int2WordOp [arg] - = simpleCoercion IntRep{-WordRep?-} res arg - -primCode [res] Word2IntOp [arg] - = simpleCoercion IntRep res arg -\end{code} - -\begin{code} -primCode [res] SameMutableArrayOp args - = let - compare = StPrim AddrEqOp (map amodeToStix args) - assign = StAssign IntRep (amodeToStix res) compare - in - returnUs (\xs -> assign : xs) - -primCode res@[_] SameMutableByteArrayOp args - = primCode res SameMutableArrayOp args - -primCode res@[_] SameMutVarOp args - = primCode res SameMutableArrayOp args - -primCode res@[_] SameMVarOp args - = primCode res SameMutableArrayOp args -\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). - -\begin{code} - -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 - returnUs (\xs -> assign : freeze : xs) - -primCode [lhs] UnsafeFreezeByteArrayOp [rhs] - = simpleCoercion PtrRep lhs rhs -\end{code} - -Returning the size of (mutable) byte arrays is just -an indexing operation. - -\begin{code} -primCode [lhs] SizeofByteArrayOp [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) - -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} +ToDo: saving/restoring of volatile regs around ccalls. -Most other array primitives translate to simple indexing. +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@[_] 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')) +foreignCallCode lhs call@(CCall (CCallSpec ctarget cconv safety)) rhs + + | not (playSafe safety) + = returnUs (\xs -> ccall : xs) + + | otherwise + = save_thread_state `thenUs` \ save -> + load_thread_state `thenUs` \ load -> + getUniqueUs `thenUs` \ uniq -> + let + id = StixTemp (StixVReg uniq IntRep) + + is_threadSafe + | playThreadSafe safety = 1 + | otherwise = 0 + + suspend = StAssignReg IntRep id + (StCall (Left FSLIT("suspendThread")) {-no:cconv-} CCallConv + IntRep [StReg stgBaseReg, StInt is_threadSafe ]) + resume = StVoidable + (StCall (Left FSLIT("resumeThread")) {-no:cconv-} CCallConv + VoidRep [StReg id, StInt is_threadSafe ]) 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) - -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) - --- NB: indexing in "pk" units, *not* in bytes (WDP 95/09) -primCode ls IndexByteArrayOp_Char rs = primCode_ReadByteArrayOp Int8Rep 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_Int64 rs = primCode_ReadByteArrayOp Int64Rep ls rs -primCode ls IndexByteArrayOp_Word64 rs = primCode_ReadByteArrayOp Word64Rep ls rs - -primCode ls ReadByteArrayOp_Char rs = primCode_ReadByteArrayOp Int8Rep 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_Int64 rs = primCode_ReadByteArrayOp Int64Rep ls rs -primCode ls ReadByteArrayOp_Word64 rs = primCode_ReadByteArrayOp Word64Rep ls rs - -primCode ls ReadOffAddrOp_Char rs = primCode_IndexOffAddrOp Int8Rep 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_Int64 rs = primCode_IndexOffAddrOp Int64Rep ls rs -primCode ls ReadOffAddrOp_Word64 rs = primCode_IndexOffAddrOp Word64Rep ls rs - -primCode ls IndexOffAddrOp_Char rs = primCode_IndexOffAddrOp Int8Rep 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_Int64 rs = primCode_IndexOffAddrOp Int64Rep ls rs -primCode ls IndexOffAddrOp_Word64 rs = primCode_IndexOffAddrOp Word64Rep ls rs - -primCode ls IndexOffForeignObjOp_Char rs = primCode_IndexOffForeignObjOp Int8Rep 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_Int64 rs = primCode_IndexOffForeignObjOp Int64Rep ls rs -primCode ls IndexOffForeignObjOp_Word64 rs = primCode_IndexOffForeignObjOp Word64Rep ls rs - -primCode ls WriteOffAddrOp_Char rs = primCode_WriteOffAddrOp Int8Rep 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_Int64 rs = primCode_WriteOffAddrOp Int64Rep ls rs -primCode ls WriteOffAddrOp_Word64 rs = primCode_WriteOffAddrOp Word64Rep ls rs - -primCode ls WriteByteArrayOp_Char rs = primCode_WriteByteArrayOp Int8Rep 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_Int64 rs = primCode_WriteByteArrayOp Int64Rep ls rs -primCode ls WriteByteArrayOp_Word64 rs = primCode_WriteByteArrayOp Word64Rep ls rs - -\end{code} - -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)) + 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 + (cargs, stix_target) + = case ctarget of + StaticTarget nm -> (rhs, Left nm) + DynamicTarget | notNull rhs -- an assertion + -> (tail rhs, Right (amodeToStix (head rhs))) + + stix_args = map amodeToStix' cargs ccall = case lhs of - [] -> StCall fn cconv VoidRep args - [lhs] -> - let lhs' = amodeToStix lhs - pk = case getAmodeRep lhs of + [] -> StVoidable (StCall stix_target cconv VoidRep stix_args) + [lhs] -> mkStAssign pk lhs' (StCall stix_target cconv pk stix_args) + where + lhs' = amodeToStix lhs + pk = case getAmodeRep lhs of FloatRep -> FloatRep DoubleRep -> DoubleRep + Int64Rep -> Int64Rep + Word64Rep -> Word64Rep other -> IntRep - in - StAssign pk lhs' (StCall fn cconv pk args) -\end{code} - -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 - 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} - -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) - -primCode [] TouchOp [_] = returnUs id -\end{code} - -Now the more mundane operations. - -\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} - -Helper fns for some array ops. - -\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 - returnUs (\xs -> assign : xs) - - -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 - returnUs (\xs -> assign : xs) - -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) - - -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 - 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) - -\end{code} - -\begin{code} -simpleCoercion - :: PrimRep - -> CAddrMode - -> CAddrMode - -> UniqSM StixTreeList - -simpleCoercion pk lhs rhs - = returnUs (\xs -> StAssign pk (amodeToStix lhs) (amodeToStix rhs) : xs) +-- a bit late to catch this here.. +foreignCallCode _ DNCall{} _ + = panic "foreignCallCode: .NET interop not supported via NCG; compile with -fvia-C" \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. - -\begin{code} -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_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. +%************************************************************************ +%* * +\subsubsection{Code for @CAddrMode@s} +%* * +%************************************************************************ 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 +amodeToStix, amodeToStix' :: CAddrMode -> StixExpr amodeToStix'{-'-} am@(CVal rr CharRep) - | mixedTypeLocn am = StPrim ChrOp [amodeToStix am] - | otherwise = amodeToStix am - -amodeToStix' am = amodeToStix am + | mixedTypeLocn am = StMachOp MO_NatS_to_32U [amodeToStix am] + | otherwise = amodeToStix am +amodeToStix' am + = amodeToStix am ----------- amodeToStix am@(CVal rr CharRep) @@ -476,75 +140,80 @@ amodeToStix am@(CVal rr CharRep) amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr)) amodeToStix (CAddr (SpRel off)) - = StIndex PtrRep stgSp (StInt (toInteger (iBox off))) + = StIndex PtrRep (StReg stgSp) (StInt (toInteger (iBox off))) amodeToStix (CAddr (HpRel off)) - = StIndex IntRep stgHp (StInt (toInteger (- (iBox off)))) + = StIndex IntRep (StReg stgHp) (StInt (toInteger (- (iBox off)))) amodeToStix (CAddr (NodeRel off)) - = StIndex IntRep stgNode (StInt (toInteger (iBox off))) + = StIndex IntRep (StReg stgNode) (StInt (toInteger (iBox off))) amodeToStix (CAddr (CIndex base off pk)) = StIndex pk (amodeToStix base) (amodeToStix off) amodeToStix (CReg magic) = StReg (StixMagicId magic) -amodeToStix (CTemp uniq pk) = StReg (StixTemp uniq pk) +amodeToStix (CTemp uniq pk) = StReg (StixTemp (StixVReg uniq pk)) amodeToStix (CLbl lbl _) = StCLbl lbl -- For CharLike and IntLike, we attempt some trivial constant-folding here. amodeToStix (CCharLike (CLit (MachChar c))) - = StIndex Int8Rep cHARLIKE_closure (StInt (toInteger off)) + = StIndex Word8Rep cHARLIKE_closure (StInt (toInteger off)) where - off = charLikeSize * (c - mIN_CHARLIKE) + off = charLikeSize * (ord c - mIN_CHARLIKE) amodeToStix (CCharLike x) - = panic "CCharLike" + = panic "amodeToStix.CCharLike" amodeToStix (CIntLike (CLit (MachInt i))) - = StIndex Int8Rep iNTLIKE_closure (StInt (toInteger off)) + = StIndex Word8Rep iNTLIKE_closure (StInt (toInteger off)) where off = intLikeSize * (fromInteger (i - mIN_INTLIKE)) amodeToStix (CIntLike x) - = panic "CIntLike" + = panic "amodeToStix.CIntLike" amodeToStix (CLit core) = case core of - MachChar c -> StInt (toInteger c) + MachChar c -> StInt (toInteger (ord c)) MachStr s -> StString s - MachAddr a -> StInt a + MachNullAddr -> StInt 0 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-}) + -- dreadful, but rare. + MachLabel l (Just x) -> StCLbl (mkForeignLabel (mkFastString (unpackFS l ++ '@':show x)) False) + 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 + = let + arg_amode = amodeToStix arg + in + case macro of + ENTRY_CODE -> arg_amode + ARG_TAG -> arg_amode -- just an integer no. of words GET_TAG -> #ifdef WORDS_BIGENDIAN - StPrim AndOp - [StInd WordRep (StIndex PtrRep (amodeToStix arg) + StMachOp MO_Nat_And + [StInd WordRep (StIndex PtrRep arg_amode (StInt (toInteger (-1)))), StInt 65535] #else - StPrim SrlOp - [StInd WordRep (StIndex PtrRep (amodeToStix arg) + StMachOp MO_Nat_Shr + [StInd WordRep (StIndex PtrRep arg_amode (StInt (toInteger (-1)))), StInt 16] #endif - UPD_FRAME_UPDATEE - -> StInd PtrRep (StIndex PtrRep (amodeToStix arg) - (StInt (toInteger uF_UPDATEE))) + BYTE_ARR_CTS -> StIndex IntRep arg_amode arrWordsHS + PTRS_ARR_CTS -> StIndex PtrRep arg_amode arrPtrsHS + ForeignObj_CLOSURE_DATA -> StInd PtrRep (StIndex PtrRep arg_amode fixedHS) + -litLitErr = - panic "native code generator can't compile lit-lits, use -fvia-C" +amodeToStix other + = pprPanic "StixPrim.amodeToStix" (pprAmode other) \end{code} Sizes of the CharLike and IntLike closures that are arranged as arrays @@ -553,73 +222,85 @@ in the data segment. (These are in bytes.) \begin{code} -- The INTLIKE base pointer -iNTLIKE_closure :: StixTree +iNTLIKE_closure :: StixExpr iNTLIKE_closure = StCLbl mkIntlikeClosureLabel -- The CHARLIKE base -cHARLIKE_closure :: StixTree +cHARLIKE_closure :: StixExpr cHARLIKE_closure = StCLbl mkCharlikeClosureLabel -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)) +charLikeSize = (fixedHdrSize + 1) * (getPrimRepSizeInBytes PtrRep) +intLikeSize = (fixedHdrSize + 1) * (getPrimRepSizeInBytes PtrRep) \end{code} \begin{code} save_thread_state - = getUniqueUs `thenUs` \tso_uq -> - let tso = StReg (StixTemp tso_uq ThreadIdRep) in + = getUniqueUs `thenUs` \ tso_uq -> + let tso = StixTemp (StixVReg tso_uq PtrRep) 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 + StAssignReg PtrRep tso (StReg stgCurrentTSO) + : StAssignMem PtrRep + (StMachOp MO_Nat_Add + [StReg tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))]) + (StReg stgSp) + : StAssignMem PtrRep + (StMachOp MO_Nat_Add + [StReg stgCurrentNursery, + StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))]) + (StMachOp MO_Nat_Add + [StReg stgHp, StInt (toInteger (1 * BYTES_PER_WORD))]) + : xs ) load_thread_state - = getUniqueUs `thenUs` \tso_uq -> - let tso = StReg (StixTemp tso_uq ThreadIdRep) in + = getUniqueUs `thenUs` \ tso_uq -> + let tso = StixTemp (StixVReg tso_uq PtrRep) 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 + StAssignReg PtrRep tso (StReg stgCurrentTSO) + : StAssignReg PtrRep + stgSp + (StInd PtrRep + (StMachOp MO_Nat_Add + [StReg tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))])) + : StAssignReg PtrRep + stgSpLim + (StMachOp MO_Nat_Add + [StReg tso, + StInt (toInteger ((TSO_STACK + rESERVED_STACK_WORDS) + *BYTES_PER_WORD))]) + : StAssignReg PtrRep + stgHp + (StMachOp MO_Nat_Sub + [StInd PtrRep + (StMachOp MO_Nat_Add + [StReg stgCurrentNursery, + StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))]), + StInt (toInteger (1 * BYTES_PER_WORD)) + ]) + : StAssignReg PtrRep + stgHpLim + (StIndex Word8Rep + (StInd PtrRep + (StIndex PtrRep (StReg stgCurrentNursery) + (StInt (toInteger BDESCR_START)) + ) + ) + (StMachOp MO_Nat_Sub + [StMachOp MO_NatU_Mul + [StInd WordRep + (StIndex PtrRep (StReg stgCurrentNursery) + (StInt (toInteger BDESCR_BLOCKS))), + StInt (toInteger bLOCK_SIZE{-in bytes-}) + ], + StInt (1 * BYTES_PER_WORD) + ] + ) + + ) + + : xs ) \end{code}