%
-% (c) The AQUA Project, Glasgow University, 1993-1996
+% (c) The AQUA Project, Glasgow University, 1993-1998
%
\begin{code}
#include "HsVersions.h"
-import Char ( ord )
import MachMisc
import MachRegs
+import Stix
+import StixInteger
-import AbsCSyn
+import AbsCSyn hiding ( spRel )
import AbsCUtils ( getAmodeRep, mixedTypeLocn )
+import SMRep ( fixedHdrSize )
+import Const ( Literal(..) )
import CallConv ( cCallConv )
-import Constants ( spARelToInt, spBRelToInt )
-import CostCentre ( noCostCentreAttached )
-import HeapOffs ( hpRelToInt, subOff )
-import Literal ( Literal(..) )
-import PrimOp ( PrimOp(..), isCompareOp, showPrimOp,
- getPrimOpResultInfo, PrimOpResultInfo(..)
- )
+import PrimOp ( PrimOp(..) )
import PrimRep ( PrimRep(..), isFloatingRep )
-import OrdList ( OrdList )
-import SMRep ( SMRep(..), SMSpecRepKind, SMUpdateKind )
-import Stix
-import StixMacro ( heapCheck )
-import StixInteger {- everything -}
import UniqSupply ( returnUs, thenUs, UniqSM )
+import Constants ( mIN_INTLIKE )
import Outputable
+import Char ( ord )
\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
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
\begin{code}
-- 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)
+primCode res@[ar,sr,dr] IntegerNegOp arg@[aa,sa,da]
+ = gmpNegate (ar,sr,dr) (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@[aa1,sa1,da1, aa2,sa2,da2]
+ = gmpCompare res (aa1,sa1,da1, aa2,sa2,da2)
-primCode res@[ar,sr,dr] Int2IntegerOp args@[hp, n]
- = gmpInt2Integer (ar,sr,dr) (hp, n)
+primCode [res] Integer2IntOp arg@[aa,sa,da]
+ = gmpInteger2Int res (aa,sa,da)
-primCode res@[ar,sr,dr] Addr2IntegerOp args@[liveness,str]
- = gmpString2Integer (ar,sr,dr) (liveness,str)
-
-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] Integer2WordOp arg@[hp, aa,sa,da]
- = gmpInteger2Word 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@[aa,sa,da]
+ = gmpInteger2Word res (aa,sa,da)
primCode [res] Int2AddrOp [arg]
= simpleCoercion AddrRep res arg
= simpleCoercion IntRep res arg
\end{code}
-The @ErrorIO@ primitive is actually a bit weird...assign a new value
-to the root closure, and jump to the @ErrorIO_innards@.
-
-\begin{code}
-primCode [] ErrorIOPrimOp [rhs]
- = let
- changeTop = StAssign PtrRep topClosure (amodeToStix rhs)
- in
- returnUs (\xs -> changeTop : 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") cCallConv 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)
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)
lhs' = amodeToStix lhs
obj' = amodeToStix obj
ix' = amodeToStix ix
- base = StIndex IntRep obj' mutHS
+ base = StIndex IntRep obj' arrHS
assign = StAssign PtrRep lhs' (StInd PtrRep (StIndex PtrRep base ix'))
in
returnUs (\xs -> assign : xs)
obj' = amodeToStix obj
ix' = amodeToStix ix
v' = amodeToStix v
- base = StIndex IntRep obj' mutHS
+ base = StIndex IntRep obj' arrHS
assign = StAssign PtrRep (StInd PtrRep (StIndex PtrRep base ix')) v'
in
returnUs (\xs -> assign : xs)
lhs' = amodeToStix lhs
obj' = amodeToStix obj
ix' = amodeToStix ix
- base = StIndex IntRep obj' dataHS
+ base = StIndex IntRep obj' arrHS
assign = StAssign pk lhs' (StInd pk (StIndex pk base ix'))
in
returnUs (\xs -> assign : xs)
lhs' = amodeToStix lhs
obj' = amodeToStix obj
ix' = amodeToStix ix
- obj'' = StIndex PtrRep obj' foHS
+ obj'' = StIndex PtrRep obj' fixedHS
assign = StAssign pk lhs' (StInd pk (StIndex pk obj'' ix'))
in
returnUs (\xs -> assign : xs)
obj' = amodeToStix obj
ix' = amodeToStix ix
v' = amodeToStix v
- base = StIndex IntRep obj' dataHS
+ base = StIndex IntRep obj' arrHS
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]
- = let
- lhs' = amodeToStix lhs
- pk = getAmodeRep lhs
- sp' = amodeToStix sp
- call = StCall SLIT("deRefStablePointer") cCallConv pk [sp', smStablePtrTable]
- assign = StAssign pk lhs' call
- 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}
-
\begin{code}
-primCode res Word2IntegerOp args = panic "primCode:Word2IntegerOp"
-
-primCode [lhs] SeqOp [a]
- = let
- {-
- The evaluation of seq#'s argument is done by `seqseqseq',
- here we just set up the call to it (identical to how
- DerefStablePtr does things.)
- -}
- lhs' = amodeToStix lhs
- a' = amodeToStix a
- pk = getAmodeRep lhs -- an IntRep
- call = StCall SLIT("SeqZhCode") cCallConv pk [a']
- assign = StAssign pk lhs' call
- in
--- trace "SeqOp" $
- returnUs (\xs -> assign : xs)
-
-primCode lhs (CCallOp (Left fn) is_asm may_gc cconv arg_tys result_ty) rhs
+--primCode lhs (CCallOp fn is_asm may_gc) rhs
+primCode lhs (CCallOp (Left fn) is_asm may_gc cconv) rhs
| is_asm = error "ERROR: Native code generator can't handle casm"
| may_gc = error "ERROR: Native code generator can't handle _ccall_GC_\n"
| otherwise
let base = amodeToStix' x
in
case getAmodeRep x of
- ArrayRep -> StIndex PtrRep base mutHS
- ByteArrayRep -> StIndex IntRep base dataHS
- ForeignObjRep -> StIndex PtrRep base foHS
- {-error "ERROR: native-code generator can't handle ForeignObjs (yet): use -fvia-C!"-}
+ ArrayRep -> StIndex PtrRep base arrHS
+ ByteArrayRep -> StIndex IntRep base arrHS
+ ForeignObjRep -> StIndex PtrRep base fixedHS
_ -> base
\end{code}
= 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}
\begin{code}
simplePrim
- :: [StixTree]
+ :: PrimRep -- Rep of first destination
+ -> [StixTree] -- Destinations
-> PrimOp
-> [StixTree]
-> StixTree
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 as op bs = 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 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}
%---------------------------------------------------------------------
amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
-amodeToStix (CAddr (SpARel spA off))
- = StIndex PtrRep stgSpA (StInt (toInteger (spARelToInt spA off)))
-
-amodeToStix (CAddr (SpBRel spB off))
- = StIndex IntRep stgSpB (StInt (toInteger (spBRelToInt spB off)))
+amodeToStix (CAddr (SpRel off))
+ = StIndex PtrRep stgSp (StInt (toInteger IBOX(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 (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 ((<>) (ptext SLIT("CHARLIKE_closures+")) (int off))
+ = StLitLbl ((<>) (ptext SLIT("CHARLIKE_closure+")) (int off))
where
off = charLikeSize * ord c
amodeToStix (CCharLike x)
- = StPrim IntAddOp [charLike, off]
+ = StIndex PtrRep charLike off
where
- off = StPrim IntMulOp [amodeToStix x, StInt (toInteger charLikeSize)]
+ off = StPrim IntMulOp [amodeToStix x, StInt (toInteger (fixedHdrSize+1))]
amodeToStix (CIntLike (CLit (MachInt i _)))
- = StPrim IntAddOp [intLikePtr, StInt off]
+ = StLitLbl ((<>) (ptext SLIT("INTLIKE_closure+")) (int off))
where
- off = toInteger intLikeSize * toInteger i
+ off = intLikeSize * (fromInteger (i - mIN_INTLIKE))
amodeToStix (CIntLike x)
- = StPrim IntAddOp [intLikePtr, off]
- where
- off = StPrim IntMulOp [amodeToStix x, StInt (toInteger intLikeSize)]
+ = panic "CIntLike"
-- A CString is just a (CLit . MachStr)
amodeToStix (CString s) = StString s
-- 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 "amodeToStix:CCostCentre"
+ ARG_TAG -> amodeToStix arg -- just an integer no. of words
+ GET_TAG -> StPrim SrlOp
+ [StInd WordRep (StPrim IntSubOp [amodeToStix arg,
+ StInt 1]),
+ StInt 16]
+
+-- XXX!!!
+-- GET_TAG(info_ptr) is supposed to be get_itbl(info_ptr)->srt_len,
+-- which we've had to hand-code here.
\end{code}
Sizes of the CharLike and IntLike closures that are arranged as arrays
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 = StInd PtrRep (sStLitLbl SLIT("TopClosure"))
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}
projects / ghc-hetmet.git / blobdiff