X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FnativeGen%2FStixPrim.lhs;h=034e6410259cfa6169a3086b1b73159420bcc586;hb=0b3dcf9dd504c2db156d08f1908e906e00e66c7a;hp=c986b3117b37e973c259ed2e66938394831706a9;hpb=e7498a3ee1d0484d02a9e86633cc179c76ebf36e;p=ghc-hetmet.git diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs index c986b31..034e641 100644 --- a/ghc/compiler/nativeGen/StixPrim.lhs +++ b/ghc/compiler/nativeGen/StixPrim.lhs @@ -1,49 +1,36 @@ % -% (c) The AQUA Project, Glasgow University, 1993-1996 +% (c) The AQUA Project, Glasgow University, 1993-1998 % \begin{code} -#include "HsVersions.h" - module StixPrim ( primCode, amodeToStix, amodeToStix' ) where -IMP_Ubiq(){-uitous-} -IMPORT_DELOOPER(NcgLoop) -- paranoia checking only +#include "HsVersions.h" import MachMisc import MachRegs +import Stix +import StixInteger -import AbsCSyn +import AbsCSyn hiding ( spRel ) import AbsCUtils ( getAmodeRep, mixedTypeLocn ) -import CgCompInfo ( spARelToInt, spBRelToInt ) -import CostCentre ( noCostCentreAttached ) -import HeapOffs ( hpRelToInt, subOff ) -import Literal ( Literal(..) ) -import PrimOp ( PrimOp(..), isCompareOp, showPrimOp, - getPrimOpResultInfo, PrimOpResultInfo(..) - ) +import SMRep ( fixedHdrSize ) +import Literal ( Literal(..), word2IntLit ) +import CallConv ( cCallConv ) +import PrimOp ( PrimOp(..), CCall(..), CCallTarget(..) ) import PrimRep ( PrimRep(..), isFloatingRep ) -import OrdList ( OrdList ) -import PprStyle ( PprStyle(..) ) -import SMRep ( SMRep(..), SMSpecRepKind, SMUpdateKind ) -import Stix -import StixMacro ( heapCheck, smStablePtrTable ) -import StixInteger {- everything -} -import UniqSupply ( returnUs, thenUs, UniqSM(..) ) -import Unpretty ( uppBeside, uppPStr, uppInt ) -import Util ( panic ) - -#ifdef REALLY_HASKELL_1_3 -ord = fromEnum :: Char -> Int -#endif +import UniqSupply ( returnUs, thenUs, getUniqueUs, UniqSM ) +import Constants ( mIN_INTLIKE, uF_UPDATEE, bLOCK_SIZE ) +import Outputable + +import Char ( ord, isAlphaNum ) + +#include "NCG.h" \end{code} 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") - primCode :: [CAddrMode] -- results -> PrimOp -- op @@ -56,8 +43,6 @@ 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 ForeignObjs. - btw Why not let programmer use casm to provide assembly code instead of C code? ADR @@ -69,56 +54,20 @@ 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@[ar1,sr1,dr1, ar2,sr2,dr2] - IntegerQuotRemOp - args@[liveness, aa1,sa1,da1, aa2,sa2,da2] - = gmpTake2Return2 (ar1,sr1,dr1, ar2,sr2,dr2) SLIT("mpz_divmod") (liveness, aa1,sa1,da1, aa2,sa2,da2) - -primCode res@[ar1,sr1,dr1, ar2,sr2,dr2] - IntegerDivModOp - args@[liveness, aa1,sa1,da1, aa2,sa2,da2] - = gmpTake2Return2 (ar1,sr1,dr1, ar2,sr2,dr2) SLIT("mpz_targetivmod") (liveness, aa1,sa1,da1, aa2,sa2,da2) - -primCode res@[ar,sr,dr] IntegerAddOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2] - = gmpTake2Return1 (ar,sr,dr) SLIT("mpz_add") (liveness, aa1,sa1,da1, aa2,sa2,da2) -primCode res@[ar,sr,dr] IntegerSubOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2] - = gmpTake2Return1 (ar,sr,dr) SLIT("mpz_sub") (liveness, aa1,sa1,da1, aa2,sa2,da2) -primCode res@[ar,sr,dr] IntegerMulOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2] - = gmpTake2Return1 (ar,sr,dr) SLIT("mpz_mul") (liveness, aa1,sa1,da1, aa2,sa2,da2) - -primCode res@[ar,sr,dr] IntegerNegOp arg@[liveness,aa,sa,da] - = gmpTake1Return1 (ar,sr,dr) SLIT("mpz_neg") (liveness,aa,sa,da) -\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@[exponr,ar,sr,dr] FloatDecodeOp args@[hp, arg] - = decodeFloatingKind FloatRep (exponr,ar,sr,dr) (hp, arg) - -primCode res@[exponr,ar,sr,dr] DoubleDecodeOp args@[hp, arg] - = decodeFloatingKind DoubleRep (exponr,ar,sr,dr) (hp, arg) +primCode [res] IntegerCmpOp args@[sa1,da1, sa2,da2] + = gmpCompare res (sa1,da1, sa2,da2) -primCode res@[ar,sr,dr] Int2IntegerOp args@[hp, n] - = gmpInt2Integer (ar,sr,dr) (hp, n) +primCode [res] IntegerCmpIntOp args@[sa1,da1,ai] + = gmpCompareInt res (sa1,da1,ai) -primCode res@[ar,sr,dr] Addr2IntegerOp args@[liveness,str] - = gmpString2Integer (ar,sr,dr) (liveness,str) +primCode [res] Integer2IntOp arg@[sa,da] + = gmpInteger2Int res (sa,da) -primCode [res] IntegerCmpOp args@[hp, aa1,sa1,da1, aa2,sa2,da2] - = gmpCompare res (hp, aa1,sa1,da1, aa2,sa2,da2) - -primCode [res] Integer2IntOp arg@[hp, aa,sa,da] - = gmpInteger2Int res (hp, aa,sa,da) - -primCode [res] FloatEncodeOp args@[hp, aa,sa,da, expon] - = encodeFloatingKind FloatRep res (hp, aa,sa,da, expon) - -primCode [res] DoubleEncodeOp args@[hp, aa,sa,da, expon] - = encodeFloatingKind DoubleRep res (hp, aa,sa,da, expon) +primCode [res] Integer2WordOp arg@[sa,da] + = gmpInteger2Word res (sa,da) primCode [res] Int2AddrOp [arg] = simpleCoercion AddrRep res arg @@ -133,58 +82,7 @@ primCode [res] Word2IntOp [arg] = simpleCoercion IntRep res arg \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@. - -\begin{code} -primCode [] ErrorIOPrimOp [rhs] - = let - changeTop = StAssign PtrRep topClosure (amodeToStix rhs) - in - returnUs (\xs -> changeTop : flushStdout : flushStderr : errorIO : xs) -\end{code} - -@newArray#@ ops allocate heap space. - \begin{code} -primCode [res] NewArrayOp args - = let - [liveness, n, initial] = map amodeToStix args - result = amodeToStix res - space = StPrim IntAddOp [n, mutHS] - loc = StIndex PtrRep stgHp - (StPrim IntNegOp [StPrim IntSubOp [space, StInt 1]]) - assign = StAssign PtrRep result loc - initialise = StCall SLIT("newArrZh_init") VoidRep [result, n, initial] - in - heapCheck liveness space (StInt 0) `thenUs` \ heap_chk -> - - returnUs (heap_chk . (\xs -> assign : initialise : xs)) - -primCode [res] (NewByteArrayOp pk) args - = let - [liveness, count] = map amodeToStix args - result = amodeToStix res - n = StPrim IntMulOp [count, StInt (sizeOf pk)] - slop = StPrim IntAddOp [n, StInt (sizeOf IntRep - 1)] - words = StPrim IntQuotOp [slop, StInt (sizeOf IntRep)] - space = StPrim IntAddOp [n, StPrim IntAddOp [words, dataHS]] - loc = StIndex PtrRep stgHp - (StPrim IntNegOp [StPrim IntSubOp [space, StInt 1]]) - assign = StAssign PtrRep result loc - init1 = StAssign PtrRep (StInd PtrRep loc) arrayOfData_info - init2 = StAssign IntRep - (StInd IntRep - (StIndex IntRep loc - (StInt (toInteger fixedHdrSizeInWords)))) - (StPrim IntAddOp [words, - StInt (toInteger (varHdrSizeInWords (DataRep 0)))]) - in - heapCheck liveness space (StInt 0) `thenUs` \ heap_chk -> - - returnUs (heap_chk . (\xs -> assign : init1 : init2 : xs)) - primCode [res] SameMutableArrayOp args = let compare = StPrim AddrEqOp (map amodeToStix args) @@ -194,6 +92,12 @@ primCode [res] SameMutableArrayOp args 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 @@ -208,7 +112,7 @@ primCode [lhs] UnsafeFreezeArrayOp [rhs] rhs' = amodeToStix rhs header = StInd PtrRep lhs' assign = StAssign PtrRep lhs' rhs' - freeze = StAssign PtrRep header imMutArrayOfPtrs_info + freeze = StAssign PtrRep header mutArrPtrsFrozen_info in returnUs (\xs -> assign : freeze : xs) @@ -216,10 +120,33 @@ primCode [lhs] UnsafeFreezeByteArrayOp [rhs] = simpleCoercion PtrRep lhs rhs \end{code} -Most other array primitives translate to simple indexing. +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} + +Most other array primitives translate to simple indexing. + +\begin{code} primCode lhs@[_] IndexArrayOp args = primCode lhs ReadArrayOp args @@ -228,17 +155,17 @@ primCode [lhs] ReadArrayOp [obj, ix] lhs' = amodeToStix lhs obj' = amodeToStix obj ix' = amodeToStix ix - base = StIndex IntRep obj' mutHS + base = StIndex IntRep obj' arrPtrsHS assign = StAssign PtrRep lhs' (StInd PtrRep (StIndex PtrRep base ix')) in returnUs (\xs -> assign : xs) -primCode [lhs] WriteArrayOp [obj, ix, v] +primCode [] WriteArrayOp [obj, ix, v] = let obj' = amodeToStix obj ix' = amodeToStix ix v' = amodeToStix v - base = StIndex IntRep obj' mutHS + base = StIndex IntRep obj' arrPtrsHS assign = StAssign PtrRep (StInd PtrRep (StIndex PtrRep base ix')) v' in returnUs (\xs -> assign : xs) @@ -253,11 +180,14 @@ primCode [lhs] (ReadByteArrayOp pk) [obj, ix] lhs' = amodeToStix lhs obj' = amodeToStix obj ix' = amodeToStix ix - base = StIndex IntRep obj' dataHS + base = StIndex IntRep obj' arrWordsHS assign = StAssign pk lhs' (StInd pk (StIndex pk base ix')) in returnUs (\xs -> assign : xs) +primCode lhs@[_] (ReadOffAddrOp pk) args + = primCode lhs (IndexOffAddrOp pk) args + primCode [lhs] (IndexOffAddrOp pk) [obj, ix] = let lhs' = amodeToStix lhs @@ -267,159 +197,123 @@ primCode [lhs] (IndexOffAddrOp pk) [obj, ix] in 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 + 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' dataHS + base = StIndex IntRep obj' arrWordsHS assign = StAssign pk (StInd pk (StIndex pk base ix')) v' in returnUs (\xs -> assign : xs) -\end{code} - -Stable pointer operations. - -First the easy one. -\begin{code} -primCode [lhs] DeRefStablePtrOp [sp] +primCode [] WriteForeignObjOp [obj, v] = let - lhs' = amodeToStix lhs - pk = getAmodeRep lhs - sp' = amodeToStix sp - call = StCall SLIT("deRefStablePointer") pk [sp', smStablePtrTable] - assign = StAssign pk lhs' call + 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} -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} -primCode [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 IntRep [x, sub [x, one]] - inc x = trAssign IntRep [x, add [x, one]] - - -- tedious hardwiring in of closure layout offsets (from SMClosures) - dynHS = 2 + fixedHdrSizeInWords + varHdrSizeInWords DynamicRep - spt_SIZE c = trIndex PtrRep [c, trInt [fhs + gc_reserved] ] - spt_NoPTRS c = trIndex PtrRep [c, trInt [fhs + gc_reserved + 1] ] - spt_SPTR c i = trIndex PtrRep [c, add [trInt [dynHS], i]] - spt_TOP c = trIndex PtrRep [c, add [trInt [dynHS], spt_NoPTRS c]] - spt_FREE c i = trIndex PtrRep [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 PtrRep [spt_FREE c (spt_TOP c), f], - inc (spt_TOP c), - spt_POP c x = [ - dec (spt_TOP c), - trAssign PtrRep [x, spt_FREE c (spt_TOP c)] - ] - - -- now to get down to business - lhs' = amodeCode lhs - [liveness, unstable] = map amodeCode 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" PtrRep [newSPT, spt] - - enlarge = - allocNewTable ++ [ - copyOldTable, - trAssign PtrRep [spt, newSPT] - allocate = [ - spt_POP spt newSP, - trAssign PtrRep [spt_SPTR spt newSP, unstable], - trAssign StablePtrRep [lhs', newSP] - ] - - in - getUniqLabelCTS `thenCTS` \ oklbl -> - returnCodes sty md - (spt_EMPTY spt oklbl : (enlarge ++ (trLabel [oklbl] : allocate))) -\end{pseudocode} +ToDo: saving/restoring of volatile regs around ccalls. \begin{code} -primCode res Word2IntegerOp args = panic "primCode:Word2IntegerOp" - -primCode lhs (CCallOp fn is_asm may_gc arg_tys result_ty) rhs +primCode lhs (CCallOp (CCall (StaticTarget fn) is_asm may_gc cconv)) rhs | is_asm = error "ERROR: Native code generator can't handle casm" - | otherwise - = case lhs of - [] -> returnUs (\xs -> (StCall fn VoidRep args) : xs) - [lhs] -> - let lhs' = amodeToStix lhs - pk = if isFloatingRep (getAmodeRep lhs) then DoubleRep else IntRep - call = StAssign pk lhs' (StCall fn pk args) - in - returnUs (\xs -> call : xs) + | 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)) + where args = map amodeCodeForCCall rhs amodeCodeForCCall x = let base = amodeToStix' x in case getAmodeRep x of - ArrayRep -> StIndex PtrRep base mutHS - ByteArrayRep -> StIndex IntRep base dataHS - ForeignObjRep -> error "ERROR: native-code generator can't handle ForeignObjs (yet): use -fvia-C!" + 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} + +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} Now the more mundane operations. @@ -429,8 +323,9 @@ primCode lhs op rhs = let lhs' = map amodeToStix lhs rhs' = map amodeToStix' rhs + pk = getAmodeRep (head lhs) in - returnUs (\ xs -> simplePrim lhs' op rhs' : xs) + returnUs (\ xs -> simplePrim pk lhs' op rhs' : xs) \end{code} \begin{code} @@ -450,7 +345,8 @@ level of the specific code generator. \begin{code} simplePrim - :: [StixTree] + :: PrimRep -- Rep of first destination + -> [StixTree] -- Destinations -> PrimOp -> [StixTree] -> StixTree @@ -459,20 +355,11 @@ simplePrim Now look for something more conventional. \begin{code} -simplePrim [lhs] op rest - = StAssign pk lhs (StPrim op rest) - where - pk = if isCompareOp op then - IntRep - else - case getPrimOpResultInfo op of - ReturnsPrim pk -> pk - _ -> simplePrim_error op - -simplePrim _ 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} %--------------------------------------------------------------------- @@ -499,83 +386,88 @@ amodeToStix am@(CVal rr CharRep) amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr)) -amodeToStix (CAddr (SpARel spA off)) - = StIndex PtrRep stgSpA (StInt (toInteger (spARelToInt spA off))) +amodeToStix (CAddr (SpRel off)) + = StIndex PtrRep stgSp (StInt (toInteger IBOX(off))) -amodeToStix (CAddr (SpBRel spB off)) - = StIndex IntRep stgSpB (StInt (toInteger (spBRelToInt spB off))) - -amodeToStix (CAddr (HpRel hp off)) - = StIndex IntRep stgHp (StInt (toInteger (-(hpRelToInt (hp `subOff` off))))) +amodeToStix (CAddr (HpRel off)) + = StIndex IntRep stgHp (StInt (toInteger (- IBOX(off)))) amodeToStix (CAddr (NodeRel off)) - = StIndex IntRep stgNode (StInt (toInteger (hpRelToInt off))) + = StIndex IntRep 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 (CLbl lbl _) = StCLbl lbl -amodeToStix (CUnVecLbl dir _) = StCLbl dir - -amodeToStix (CTableEntry base off pk) - = StInd pk (StIndex pk (amodeToStix base) (amodeToStix off)) -- For CharLike and IntLike, we attempt some trivial constant-folding here. amodeToStix (CCharLike (CLit (MachChar c))) - = StLitLbl (uppBeside (uppPStr SLIT("CHARLIKE_closures+")) (uppInt off)) + = StLitLbl ((<>) (ptext SLIT("CHARLIKE_closure+")) (int off)) where off = charLikeSize * ord c amodeToStix (CCharLike x) - = StPrim IntAddOp [charLike, off] + = StIndex CharRep charLike off where off = StPrim IntMulOp [amodeToStix x, StInt (toInteger charLikeSize)] -amodeToStix (CIntLike (CLit (MachInt i _))) - = StPrim IntAddOp [intLikePtr, StInt off] +amodeToStix (CIntLike (CLit (MachInt i))) + = StLitLbl ((<>) (ptext SLIT("INTLIKE_closure+")) (int off)) where - off = toInteger intLikeSize * i + off = intLikeSize * (fromInteger (i - mIN_INTLIKE)) amodeToStix (CIntLike x) - = StPrim IntAddOp [intLikePtr, off] - where - off = StPrim IntMulOp [amodeToStix x, StInt (toInteger intLikeSize)] - - -- A CString is just a (CLit . MachStr) -amodeToStix (CString s) = StString s + = 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 - MachLitLit s _ -> StLitLit s + MachInt i -> StInt i + MachWord w -> case word2IntLit core of MachInt iw -> StInt iw + MachLitLit s _ -> litLitToStix (_UNPK_ s) MachFloat d -> StDouble d MachDouble d -> StDouble d _ -> panic "amodeToStix:core literal" - -- A CLitLit is just a (CLit . MachLitLit) -amodeToStix (CLitLit s _) = StLitLit s - - -- COffsets are in words, not bytes! -amodeToStix (COffset off) = StInt (toInteger (hpRelToInt off)) +amodeToStix (CLitLit s _) + = litLitToStix (_UNPK_ s) amodeToStix (CMacroExpr _ macro [arg]) = case macro of - INFO_PTR -> StInd PtrRep (amodeToStix arg) ENTRY_CODE -> amodeToStix arg - INFO_TAG -> tag - EVAL_TAG -> StPrim IntGeOp [tag, StInt 0] - where - tag = StInd IntRep (StIndex IntRep (amodeToStix arg) (StInt (-2))) - -- That ``-2'' really bothers me. (JSM) (Replace w/ oTHER_TAG? [WDP]) - -amodeToStix (CCostCentre cc print_as_string) - = if noCostCentreAttached cc - then StComment SLIT("") -- sigh - else panic "amodeToStix:CCostCentre" + 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))) +-- XXX!!! +-- GET_TAG(info_ptr) is supposed to be get_itbl(info_ptr)->srt_len, +-- which we've had to hand-code here. + +litLitToStix :: String -> StixTree +litLitToStix nm + | all is_id nm = StLitLbl (text nm) + | otherwise = error ("\nlitLitToStix: can't handle `" ++ nm ++ "'\n" + ++ "suggested workaround: use flag -fvia-C\n") + + where is_id c = isAlphaNum c || c == '_' \end{code} Sizes of the CharLike and IntLike closures that are arranged as arrays @@ -586,21 +478,82 @@ in the data segment. (These are in bytes.) intLikePtr :: StixTree -intLikePtr = StInd PtrRep (sStLitLbl SLIT("INTLIKE_closures")) +intLikePtr = StInd PtrRep (sStLitLbl SLIT("INTLIKE_closure")) -- The CHARLIKE base charLike :: StixTree -charLike = sStLitLbl SLIT("CHARLIKE_closures") +charLike = sStLitLbl SLIT("CHARLIKE_closure") -- Trees for the ErrorIOPrimOp -topClosure, flushStdout, flushStderr, errorIO :: StixTree +topClosure, errorIO :: StixTree topClosure = StInd PtrRep (sStLitLbl SLIT("TopClosure")) -flushStdout = StCall SLIT("fflush") VoidRep [StLitLit SLIT("stdout")] -flushStderr = StCall SLIT("fflush") VoidRep [StLitLit SLIT("stderr")] errorIO = StJump (StInd PtrRep (sStLitLbl SLIT("ErrorIO_innards"))) + +mutArrPtrsFrozen_info = sStLitLbl SLIT("MUT_ARR_PTRS_FROZEN_info") + +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}