X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=inline;f=ghc%2Fcompiler%2FnativeGen%2FStixPrim.lhs;h=cdb4fdb65f6bdbcaecd9f52b54a601d51fdce655;hb=26741ec416bae2c502ef00a2ba0e79050a32cb67;hp=977d9ef84048327c9d9e016297f453dc2476a161;hpb=e7d21ee4f8ac907665a7e170c71d59e13a01da09;p=ghc-hetmet.git diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs index 977d9ef..cdb4fdb 100644 --- a/ghc/compiler/nativeGen/StixPrim.lhs +++ b/ghc/compiler/nativeGen/StixPrim.lhs @@ -1,313 +1,297 @@ % -% (c) The AQUA Project, Glasgow University, 1993-1995 +% (c) The AQUA Project, Glasgow University, 1993-1996 % \begin{code} #include "HsVersions.h" -module StixPrim ( - genPrimCode, amodeCode, amodeCode', +module StixPrim ( primCode, amodeToStix, amodeToStix' ) where - Target, CAddrMode, StixTree, PrimOp, SplitUniqSupply - ) where +IMP_Ubiq(){-uitous-} +IMPORT_DELOOPER(NcgLoop) -- paranoia checking only -IMPORT_Trace -- ToDo: rm debugging +import MachMisc +import MachRegs 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 AbsCUtils ( getAmodeRep, mixedTypeLocn ) import CgCompInfo ( spARelToInt, spBRelToInt ) -import MachDesc -import Pretty -import PrimKind ( isFloatingKind ) -import CostCentre -import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) ) +import CostCentre ( noCostCentreAttached ) +import HeapOffs ( hpRelToInt, subOff ) +import Literal ( Literal(..) ) +import PrimOp ( PrimOp(..), isCompareOp, showPrimOp, + getPrimOpResultInfo, PrimOpResultInfo(..) + ) +import PrimRep ( PrimRep(..), isFloatingRep ) +import OrdList ( OrdList ) +import PprStyle ( PprStyle(..) ) +import SMRep ( SMRep(..), SMSpecRepKind, SMUpdateKind ) import Stix -import StixMacro ( smStablePtrTable ) +import StixMacro ( heapCheck, smStablePtrTable ) import StixInteger {- everything -} -import SplitUniq -import Unique -import Unpretty -import Util +import UniqSupply ( returnUs, thenUs, SYN_IE(UniqSM) ) +import Unpretty ( uppBeside, uppPStr, uppInt ) +import Util ( panic ) +#ifdef REALLY_HASKELL_1_3 +ord = fromEnum :: Char -> Int +#endif \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. +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. +ToDo ADR: modify this to handle ForeignObjs. btw Why not let programmer use casm to provide assembly code instead of C code? ADR -\begin{code} - -genPrimCode target lhs (CCallOp fn is_asm may_gc arg_tys result_ty) rhs - | is_asm = error "ERROR: Native code generator can't handle casm" - | otherwise = - case lhs of - [] -> returnSUs (\xs -> (StCall fn VoidKind args) : xs) - [lhs] -> - let lhs' = amodeToStix target lhs - pk = if isFloatingKind (getAmodeKind lhs) then DoubleKind else IntKind - call = StAssign pk lhs' (StCall fn pk args) - in - returnSUs (\xs -> call : xs) - where - args = map amodeCodeForCCall rhs - amodeCodeForCCall x = - let base = amodeToStix' target x - in - case getAmodeKind x of - ArrayKind -> StIndex PtrKind base (mutHS target) - ByteArrayKind -> StIndex IntKind base (dataHS target) - MallocPtrKind -> error "ERROR: native-code generator can't handle Malloc Ptrs (yet): use -fvia-C!" - _ -> base - -\end{code} - -The @ErrorIO@ primitive is actually a bit weird...assign a new value to the root -closure, flush stdout and stderr, and jump to the @ErrorIO_innards@. +The (MP) integer operations are a true nightmare. Since we don't have +a convenient abstract way of allocating temporary variables on the (C) +stack, we use the space just below HpLim for the @MP_INT@ structures, +and modify our heap check accordingly. \begin{code} - -genPrimCode target [] ErrorIOPrimOp [rhs] = - let changeTop = StAssign PtrKind topClosure (amodeToStix target rhs) - in - returnSUs (\xs -> changeTop : flushStdout : flushStderr : errorIO : xs) - +-- NB: ordering of clauses somewhere driven by +-- the desire to getting sane patt-matching behavior + +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} -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. +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) -genPrimCode target res IntegerAddOp args = - gmpTake2Return1 target res SLIT("mpz_add") args -genPrimCode target res IntegerSubOp args = - gmpTake2Return1 target res SLIT("mpz_sub") args -genPrimCode target res IntegerMulOp args = - gmpTake2Return1 target res SLIT("mpz_mul") args - -genPrimCode target res IntegerNegOp arg = - gmpTake1Return1 target res SLIT("mpz_neg") arg +primCode res@[exponr,ar,sr,dr] DoubleDecodeOp args@[hp, arg] + = decodeFloatingKind DoubleRep (exponr,ar,sr,dr) (hp, arg) -genPrimCode target res IntegerQuotRemOp arg = - gmpTake2Return2 target res SLIT("mpz_divmod") arg -genPrimCode target res IntegerDivModOp arg = - gmpTake2Return2 target res SLIT("mpz_targetivmod") arg - -\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@[ar,sr,dr] Int2IntegerOp args@[hp, n] + = gmpInt2Integer (ar,sr,dr) (hp, n) -genPrimCode target [res] IntegerCmpOp args = gmpCompare target res args +primCode res@[ar,sr,dr] Addr2IntegerOp args@[liveness,str] + = gmpString2Integer (ar,sr,dr) (liveness,str) -genPrimCode target [res] Integer2IntOp arg = gmpInteger2Int target res arg +primCode [res] IntegerCmpOp args@[hp, aa1,sa1,da1, aa2,sa2,da2] + = gmpCompare res (hp, aa1,sa1,da1, aa2,sa2,da2) -genPrimCode target res Int2IntegerOp args = gmpInt2Integer target res args +primCode [res] Integer2IntOp arg@[hp, aa,sa,da] + = gmpInteger2Int res (hp, aa,sa,da) -genPrimCode target res Word2IntegerOp args = panic "genPrimCode:Word2IntegerOp" +primCode [res] FloatEncodeOp args@[hp, aa,sa,da, expon] + = encodeFloatingKind FloatRep res (hp, aa,sa,da, expon) -genPrimCode target res Addr2IntegerOp args = gmpString2Integer target res args +primCode [res] DoubleEncodeOp args@[hp, aa,sa,da, expon] + = encodeFloatingKind DoubleRep res (hp, aa,sa,da, expon) -genPrimCode target res FloatEncodeOp args = - encodeFloatingKind FloatKind target res args +primCode [res] Int2AddrOp [arg] + = simpleCoercion AddrRep res arg -genPrimCode target res DoubleEncodeOp args = - encodeFloatingKind DoubleKind target res args +primCode [res] Addr2IntOp [arg] + = simpleCoercion IntRep res arg -genPrimCode target res FloatDecodeOp args = - decodeFloatingKind FloatKind target res args +primCode [res] Int2WordOp [arg] + = simpleCoercion IntRep{-WordRep?-} res arg -genPrimCode target res DoubleDecodeOp args = - decodeFloatingKind DoubleKind target res args - -genPrimCode target res Int2AddrOp arg = - simpleCoercion target AddrKind res arg - -genPrimCode target res Addr2IntOp arg = - simpleCoercion target IntKind res arg - -genPrimCode target res Int2WordOp arg = - simpleCoercion target IntKind{-WordKind?-} res arg +primCode [res] Word2IntOp [arg] + = simpleCoercion IntRep res arg +\end{code} -genPrimCode target res Word2IntOp arg = - simpleCoercion target IntKind res arg +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} - -genPrimCode target [res] NewArrayOp args = - let [liveness, n, initial] = map (amodeToStix target) args - result = amodeToStix target res - space = StPrim IntAddOp [n, mutHS target] - loc = StIndex PtrKind stgHp +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 PtrKind result loc - initialise = StCall SLIT("newArrZh_init") VoidKind [result, n, initial] + assign = StAssign PtrRep result loc + initialise = StCall SLIT("newArrZh_init") VoidRep [result, n, initial] in - heapCheck target liveness space (StInt 0) - `thenSUs` \ heap_chk -> - - returnSUs (heap_chk . (\xs -> assign : initialise : xs)) - -genPrimCode target [res] (NewByteArrayOp pk) args = - let [liveness, count] = map (amodeToStix target) args - result = amodeToStix target res - n = StPrim IntMulOp [count, StInt (toInteger (sizeof target pk))] - slop = StPrim IntAddOp [n, StInt (toInteger (sizeof target IntKind - 1))] - words = StPrim IntDivOp [slop, StInt (toInteger (sizeof target IntKind))] - space = StPrim IntAddOp [n, StPrim IntAddOp [words, dataHS target]] - loc = StIndex PtrKind stgHp + 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 PtrKind result loc - init1 = StAssign PtrKind (StInd PtrKind loc) arrayOfData_info - init2 = StAssign IntKind - (StInd IntKind - (StIndex IntKind loc - (StInt (toInteger (fixedHeaderSize target))))) - (StPrim IntAddOp [words, - StInt (toInteger (varHeaderSize target - (DataRep 0)))]) + 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 target liveness space (StInt 0) - `thenSUs` \ heap_chk -> + heapCheck liveness space (StInt 0) `thenUs` \ heap_chk -> - returnSUs (heap_chk . (\xs -> assign : init1 : init2 : xs)) + returnUs (heap_chk . (\xs -> assign : init1 : init2 : xs)) -genPrimCode target [res] SameMutableArrayOp args = - let compare = StPrim AddrEqOp (map (amodeToStix target) args) - assign = StAssign IntKind (amodeToStix target res) compare +primCode [res] SameMutableArrayOp args + = let + compare = StPrim AddrEqOp (map amodeToStix args) + assign = StAssign IntRep (amodeToStix res) compare in - returnSUs (\xs -> assign : xs) - -genPrimCode target res SameMutableByteArrayOp args = - genPrimCode target res SameMutableArrayOp args + returnUs (\xs -> assign : xs) +primCode res@[_] SameMutableByteArrayOp 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). +Freezing an array of pointers is a double assignment. We fix the +header of the ``new'' closure because the lhs is probably a better +addressing mode for the indirection (most likely, it's a VanillaReg). \begin{code} -genPrimCode target [lhs] UnsafeFreezeArrayOp [rhs] = - let lhs' = amodeToStix target lhs - rhs' = amodeToStix target rhs - header = StInd PtrKind lhs' - assign = StAssign PtrKind lhs' rhs' - freeze = StAssign PtrKind header imMutArrayOfPtrs_info +primCode [lhs] UnsafeFreezeArrayOp [rhs] + = let + lhs' = amodeToStix lhs + rhs' = amodeToStix rhs + header = StInd PtrRep lhs' + assign = StAssign PtrRep lhs' rhs' + freeze = StAssign PtrRep header imMutArrayOfPtrs_info in - returnSUs (\xs -> assign : freeze : xs) - -genPrimCode target lhs UnsafeFreezeByteArrayOp rhs = - simpleCoercion target PtrKind lhs rhs + returnUs (\xs -> assign : freeze : xs) +primCode [lhs] UnsafeFreezeByteArrayOp [rhs] + = simpleCoercion PtrRep lhs rhs \end{code} Most other array primitives translate to simple indexing. \begin{code} -genPrimCode target lhs IndexArrayOp args = - genPrimCode target lhs ReadArrayOp args +primCode lhs@[_] IndexArrayOp args + = primCode lhs ReadArrayOp args -genPrimCode target [lhs] ReadArrayOp [obj, ix] = - let lhs' = amodeToStix target lhs - obj' = amodeToStix target obj - ix' = amodeToStix target ix - base = StIndex IntKind obj' (mutHS target) - assign = StAssign PtrKind lhs' (StInd PtrKind (StIndex PtrKind base ix')) +primCode [lhs] ReadArrayOp [obj, ix] + = let + lhs' = amodeToStix lhs + obj' = amodeToStix obj + ix' = amodeToStix ix + base = StIndex IntRep obj' mutHS + assign = StAssign PtrRep lhs' (StInd PtrRep (StIndex PtrRep base ix')) in - returnSUs (\xs -> assign : xs) - -genPrimCode target [lhs] WriteArrayOp [obj, ix, v] = - let obj' = amodeToStix target obj - ix' = amodeToStix target ix - v' = amodeToStix target v - base = StIndex IntKind obj' (mutHS target) - assign = StAssign PtrKind (StInd PtrKind (StIndex PtrKind base ix')) v' + returnUs (\xs -> assign : xs) + +primCode [lhs] WriteArrayOp [obj, ix, v] + = let + obj' = amodeToStix obj + ix' = amodeToStix ix + v' = amodeToStix v + base = StIndex IntRep obj' mutHS + assign = StAssign PtrRep (StInd PtrRep (StIndex PtrRep base ix')) v' in - returnSUs (\xs -> assign : xs) + returnUs (\xs -> assign : xs) -genPrimCode target lhs (IndexByteArrayOp pk) args = - genPrimCode target lhs (ReadByteArrayOp pk) args +primCode lhs@[_] (IndexByteArrayOp pk) args + = primCode lhs (ReadByteArrayOp pk) args -genPrimCode target [lhs] (ReadByteArrayOp pk) [obj, ix] = - let lhs' = amodeToStix target lhs - obj' = amodeToStix target obj - ix' = amodeToStix target ix - base = StIndex IntKind obj' (dataHS target) - assign = StAssign pk lhs' (StInd pk (StIndex CharKind base ix')) +-- NB: indexing in "pk" units, *not* in bytes (WDP 95/09) + +primCode [lhs] (ReadByteArrayOp pk) [obj, ix] + = let + lhs' = amodeToStix lhs + obj' = amodeToStix obj + ix' = amodeToStix ix + base = StIndex IntRep obj' dataHS + assign = StAssign pk lhs' (StInd pk (StIndex pk base ix')) in - returnSUs (\xs -> assign : xs) - -genPrimCode target [] (WriteByteArrayOp pk) [obj, ix, v] = - let obj' = amodeToStix target obj - ix' = amodeToStix target ix - v' = amodeToStix target v - base = StIndex IntKind obj' (dataHS target) - assign = StAssign pk (StInd pk (StIndex CharKind base ix')) v' + returnUs (\xs -> assign : xs) + +primCode [lhs] (IndexOffAddrOp pk) [obj, ix] + = let + lhs' = amodeToStix lhs + obj' = amodeToStix obj + ix' = amodeToStix ix + assign = StAssign pk lhs' (StInd pk (StIndex pk obj' ix')) in - returnSUs (\xs -> assign : xs) - -genPrimCode target [lhs] (IndexOffAddrOp pk) [obj, ix] = - let lhs' = amodeToStix target lhs - obj' = amodeToStix target obj - ix' = amodeToStix target ix - assign = StAssign pk lhs' (StInd pk (StIndex CharKind obj' ix')) + returnUs (\xs -> assign : xs) + +primCode [] (WriteByteArrayOp pk) [obj, ix, v] + = let + obj' = amodeToStix obj + ix' = amodeToStix ix + v' = amodeToStix v + base = StIndex IntRep obj' dataHS + assign = StAssign pk (StInd pk (StIndex pk base ix')) v' in - returnSUs (\xs -> assign : xs) - + returnUs (\xs -> assign : xs) \end{code} Stable pointer operations. First the easy one. - \begin{code} -genPrimCode target [lhs] DeRefStablePtrOp [sp] = - let lhs' = amodeToStix target lhs - pk = getAmodeKind lhs - sp' = amodeToStix target sp +primCode [lhs] DeRefStablePtrOp [sp] + = let + lhs' = amodeToStix lhs + pk = getAmodeRep lhs + sp' = amodeToStix sp call = StCall SLIT("deRefStablePointer") pk [sp', smStablePtrTable] assign = StAssign pk lhs' call in - returnSUs (\xs -> assign : xs) - + returnUs (\xs -> assign : xs) \end{code} Now the hard one. For comparison, here's the code from StgMacros: @@ -318,25 +302,25 @@ 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; \ @@ -354,39 +338,39 @@ Notes for ADR: --JSM \begin{pseudocode} -genPrimCode sty md [lhs] MakeStablePtrOp args = - let +primCode [lhs] MakeStablePtrOp args + = let -- some useful abbreviations (I'm sure these must exist already) - add = trPrim . IntAddOp + 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]] + 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 + 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]] + 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 PtrKind [spt_FREE c (spt_TOP c), f], + 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 PtrKind [x, spt_FREE c (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 sty md lhs - [liveness, unstable] = map (amodeCode sty md) args + lhs' = amodeCode lhs + [liveness, unstable] = map amodeCode args spt = smStablePtrTable @@ -394,191 +378,215 @@ genPrimCode sty md [lhs] MakeStablePtrOp args = newSP = -- another temporary allocNewTable = -- some sort fo heap allocation needed - copyOldTable = trCall "enlargeSPTable" PtrKind [newSPT, spt] + copyOldTable = trCall "enlargeSPTable" PtrRep [newSPT, spt] - enlarge = + enlarge = allocNewTable ++ [ copyOldTable, - trAssign PtrKind [spt, newSPT] + trAssign PtrRep [spt, newSPT] allocate = [ spt_POP spt newSP, - trAssign PtrKind [spt_SPTR spt newSP, unstable], - trAssign StablePtrKind [lhs', newSP] + trAssign PtrRep [spt_SPTR spt newSP, unstable], + trAssign StablePtrRep [lhs', newSP] ] - + in getUniqLabelCTS `thenCTS` \ oklbl -> - returnCodes sty md + returnCodes sty md (spt_EMPTY spt oklbl : (enlarge ++ (trLabel [oklbl] : allocate))) \end{pseudocode} +\begin{code} +primCode res Word2IntegerOp args = panic "primCode:Word2IntegerOp" + +primCode 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 + [] -> 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) + 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!" + _ -> base +\end{code} Now the more mundane operations. \begin{code} - -genPrimCode target lhs op rhs = - let lhs' = map (amodeToStix target) lhs - rhs' = map (amodeToStix' target) rhs +primCode lhs op rhs + = let + lhs' = map amodeToStix lhs + rhs' = map amodeToStix' rhs in - returnSUs (\ xs -> simplePrim target lhs' op rhs' : xs) - -simpleCoercion - :: Target - -> PrimKind - -> [CAddrMode] - -> [CAddrMode] - -> SUniqSM StixTreeList - -simpleCoercion target pk [lhs] [rhs] = - returnSUs (\xs -> StAssign pk (amodeToStix target lhs) (amodeToStix target rhs) : xs) + returnUs (\ xs -> simplePrim lhs' op rhs' : xs) +\end{code} +\begin{code} +simpleCoercion + :: PrimRep + -> CAddrMode + -> CAddrMode + -> UniqSM StixTreeList + +simpleCoercion pk lhs rhs + = returnUs (\xs -> StAssign pk (amodeToStix lhs) (amodeToStix rhs) : xs) \end{code} -Here we try to rewrite primitives into a form the code generator -can understand. Any primitives not handled here must be handled -at the level of the specific code generator. +Here we try to rewrite primitives into a form the code generator can +understand. Any primitives not handled here must be handled at the +level of the specific code generator. \begin{code} - -simplePrim - :: Target - -> [StixTree] - -> PrimOp - -> [StixTree] +simplePrim + :: [StixTree] + -> PrimOp + -> [StixTree] -> StixTree - \end{code} 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 target [lhs] op rest = StAssign pk lhs (StPrim op rest) - where pk = if isCompareOp op then IntKind - else case getPrimOpResultInfo op of - ReturnsPrim pk -> pk - _ -> simplePrim_error op - -simplePrim target _ op _ = simplePrim_error op +simplePrim _ 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") + = 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") \end{code} %--------------------------------------------------------------------- Here we generate the Stix code for CAddrModes. -When a character is fetched from a mixed type location, we have to -do an extra cast. This is reflected in amodeCode', which is for rhs +When a character is fetched from a mixed type location, we have to do +an extra cast. This is reflected in amodeCode', which is for rhs amodes that might possibly need the extra cast. \begin{code} +amodeToStix, amodeToStix' :: CAddrMode -> StixTree -amodeCode, amodeCode' - :: Target - -> CAddrMode - -> StixTree - -amodeCode' target am@(CVal rr CharKind) - | mixedTypeLocn am = StPrim ChrOp [amodeToStix target am] - | otherwise = amodeToStix target am - -amodeCode' target am = amodeToStix target am - -amodeCode target am@(CVal rr CharKind) | mixedTypeLocn am = - StInd IntKind (amodeCode target (CAddr rr)) - -amodeCode target (CVal rr pk) = StInd pk (amodeCode target (CAddr rr)) - -amodeCode target (CAddr r@(SpARel spA off)) = - StIndex PtrKind stgSpA (StInt (toInteger (spARelToInt r))) - -amodeCode target (CAddr r@(SpBRel spB off)) = - StIndex IntKind stgSpB (StInt (toInteger (spBRelToInt r))) +amodeToStix'{-'-} am@(CVal rr CharRep) + | mixedTypeLocn am = StPrim ChrOp [amodeToStix am] + | otherwise = amodeToStix am -amodeCode target (CAddr (HpRel hp off)) = - StIndex IntKind stgHp (StInt (toInteger (-(hpRel target (hp `subOff` off))))) +amodeToStix' am = amodeToStix am -amodeCode target (CAddr (NodeRel off)) = - StIndex IntKind stgNode (StInt (toInteger (hpRel target off))) +----------- +amodeToStix am@(CVal rr CharRep) + | mixedTypeLocn am + = StInd IntRep (amodeToStix (CAddr rr)) -amodeCode target (CReg magic) = StReg (StixMagicId magic) -amodeCode target (CTemp uniq pk) = StReg (StixTemp uniq pk) +amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr)) -amodeCode target (CLbl lbl _) = StCLbl lbl +amodeToStix (CAddr (SpARel spA off)) + = StIndex PtrRep stgSpA (StInt (toInteger (spARelToInt spA off))) -amodeCode target (CUnVecLbl dir _) = StCLbl dir +amodeToStix (CAddr (SpBRel spB off)) + = StIndex IntRep stgSpB (StInt (toInteger (spBRelToInt spB off))) -amodeCode target (CTableEntry base off pk) = - StInd pk (StIndex pk (amodeCode target base) (amodeCode target off)) +amodeToStix (CAddr (HpRel hp off)) + = StIndex IntRep stgHp (StInt (toInteger (-(hpRelToInt (hp `subOff` off))))) --- For CharLike and IntLike, we attempt some trivial constant-folding here. +amodeToStix (CAddr (NodeRel off)) + = StIndex IntRep stgNode (StInt (toInteger (hpRelToInt off))) -amodeCode target (CCharLike (CLit (MachChar c))) = - StLitLbl (uppBeside (uppPStr SLIT("CHARLIKE_closures+")) (uppInt off)) - where off = charLikeClosureSize target * ord c +amodeToStix (CReg magic) = StReg (StixMagicId magic) +amodeToStix (CTemp uniq pk) = StReg (StixTemp uniq pk) -amodeCode target (CCharLike x) = - StPrim IntAddOp [charLike, off] - where off = StPrim IntMulOp [amodeCode target x, - StInt (toInteger (charLikeClosureSize target))] +amodeToStix (CLbl lbl _) = StCLbl lbl +amodeToStix (CUnVecLbl dir _) = StCLbl dir -amodeCode target (CIntLike (CLit (MachInt i _))) = - StPrim IntAddOp [intLikePtr, StInt off] - where off = toInteger (intLikeClosureSize target) * i +amodeToStix (CTableEntry base off pk) + = StInd pk (StIndex pk (amodeToStix base) (amodeToStix off)) -amodeCode target (CIntLike x) = - StPrim IntAddOp [intLikePtr, off] - where off = StPrim IntMulOp [amodeCode target x, - StInt (toInteger (intLikeClosureSize target))] + -- For CharLike and IntLike, we attempt some trivial constant-folding here. --- A CString is just a (CLit . MachStr) -amodeCode target (CString s) = StString s - -amodeCode target (CLit core) = case core of - (MachChar c) -> StInt (toInteger (ord c)) - (MachStr s) -> StString s - (MachAddr a) -> StInt a - (MachInt i _) -> StInt i - (MachLitLit s _) -> StLitLit s - (MachFloat d) -> StDouble d - (MachDouble d) -> StDouble d - _ -> panic "amodeCode:core literal" - --- A CLitLit is just a (CLit . MachLitLit) -amodeCode target (CLitLit s _) = StLitLit s +amodeToStix (CCharLike (CLit (MachChar c))) + = StLitLbl (uppBeside (uppPStr SLIT("CHARLIKE_closures+")) (uppInt off)) + where + off = charLikeSize * ord c --- COffsets are in words, not bytes! -amodeCode target (COffset off) = StInt (toInteger (hpRel target off)) +amodeToStix (CCharLike x) + = StPrim IntAddOp [charLike, off] + where + off = StPrim IntMulOp [amodeToStix x, StInt (toInteger charLikeSize)] -amodeCode target (CMacroExpr _ macro [arg]) = - case macro of - INFO_PTR -> StInd PtrKind (amodeToStix target arg) - ENTRY_CODE -> amodeToStix target arg - INFO_TAG -> tag - EVAL_TAG -> StPrim IntGeOp [tag, StInt 0] +amodeToStix (CIntLike (CLit (MachInt i _))) + = StPrim IntAddOp [intLikePtr, StInt off] where - tag = StInd IntKind (StIndex IntKind (amodeToStix target arg) (StInt (-2))) - -- That ``-2'' really bothers me. (JSM) + off = toInteger intLikeSize * i -amodeCode target (CCostCentre cc print_as_string) +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 + +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 + 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 (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 "amodeCode:CCostCentre" + else panic "amodeToStix:CCostCentre" \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")) +intLikePtr = StInd PtrRep (sStLitLbl SLIT("INTLIKE_closures")) -- The CHARLIKE base @@ -590,10 +598,9 @@ charLike = sStLitLbl SLIT("CHARLIKE_closures") topClosure, flushStdout, flushStderr, errorIO :: StixTree -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"))) - +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"))) \end{code}