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@.
-
-\begin{code}
-
-genPrimCode target [] ErrorIOPrimOp [rhs] =
- let changeTop = StAssign PtrKind topClosure (amodeToStix target rhs)
- in
- returnSUs (\xs -> changeTop : flushStdout : flushStderr : errorIO : xs)
-
+-- hacking with Uncle Will:
+#define target_STRICT target@(Target _ _ _ _ _ _ _ _)
+
+genPrimCode target_STRICT res op args
+ = genprim res op args
+ where
+ a2stix = amodeToStix target
+ a2stix' = amodeToStix' target
+ mut_hs = mutHS target
+ data_hs = dataHS target
+ heap_chkr = heapCheck target
+ size_of = sizeof target
+ fixed_hs = fixedHeaderSize target
+ var_hs = varHeaderSize target
+
+ --- real code will follow... -------------
\end{code}
The (MP) integer operations are a true nightmare. Since we don't have a
heap check accordingly.
\begin{code}
-
-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
-
-genPrimCode target res IntegerQuotRemOp arg =
- gmpTake2Return2 target res SLIT("mpz_divmod") arg
-genPrimCode target res IntegerDivModOp arg =
- gmpTake2Return2 target res SLIT("mpz_targetivmod") arg
-
+ -- NB: ordering of clauses somewhere driven by
+ -- the desire to getting sane patt-matching behavior
+
+ genprim res@[ar1,sr1,dr1, ar2,sr2,dr2]
+ IntegerQuotRemOp
+ args@[liveness, aa1,sa1,da1, aa2,sa2,da2] =
+ gmpTake2Return2 target (ar1,sr1,dr1, ar2,sr2,dr2) SLIT("mpz_divmod") (liveness, aa1,sa1,da1, aa2,sa2,da2)
+
+ genprim res@[ar1,sr1,dr1, ar2,sr2,dr2]
+ IntegerDivModOp
+ args@[liveness, aa1,sa1,da1, aa2,sa2,da2] =
+ gmpTake2Return2 target (ar1,sr1,dr1, ar2,sr2,dr2) SLIT("mpz_targetivmod") (liveness, aa1,sa1,da1, aa2,sa2,da2)
+
+ genprim res@[ar,sr,dr] IntegerAddOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2] =
+ gmpTake2Return1 target (ar,sr,dr) SLIT("mpz_add") (liveness, aa1,sa1,da1, aa2,sa2,da2)
+ genprim res@[ar,sr,dr] IntegerSubOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2] =
+ gmpTake2Return1 target (ar,sr,dr) SLIT("mpz_sub") (liveness, aa1,sa1,da1, aa2,sa2,da2)
+ genprim res@[ar,sr,dr] IntegerMulOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2] =
+ gmpTake2Return1 target (ar,sr,dr) SLIT("mpz_mul") (liveness, aa1,sa1,da1, aa2,sa2,da2)
+
+ genprim res@[ar,sr,dr] IntegerNegOp arg@[liveness,aa,sa,da] =
+ gmpTake1Return1 target (ar,sr,dr) SLIT("mpz_neg") (liveness,aa,sa,da)
\end{code}
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}
+ genprim res@[exponr,ar,sr,dr] FloatDecodeOp args@[hp, arg] =
+ decodeFloatingKind FloatKind target (exponr,ar,sr,dr) (hp, arg)
+
+ genprim res@[exponr,ar,sr,dr] DoubleDecodeOp args@[hp, arg] =
+ decodeFloatingKind DoubleKind target (exponr,ar,sr,dr) (hp, arg)
-genPrimCode target [res] IntegerCmpOp args = gmpCompare target res args
+ genprim res@[ar,sr,dr] Int2IntegerOp args@[hp, n]
+ = gmpInt2Integer target (ar,sr,dr) (hp, n)
-genPrimCode target [res] Integer2IntOp arg = gmpInteger2Int target res arg
+ genprim res@[ar,sr,dr] Addr2IntegerOp args@[liveness,str]
+ = gmpString2Integer target (ar,sr,dr) (liveness,str)
-genPrimCode target res Int2IntegerOp args = gmpInt2Integer target res args
+ genprim [res] IntegerCmpOp args@[hp, aa1,sa1,da1, aa2,sa2,da2]
+ = gmpCompare target res (hp, aa1,sa1,da1, aa2,sa2,da2)
-genPrimCode target res Word2IntegerOp args = panic "genPrimCode:Word2IntegerOp"
+ genprim [res] Integer2IntOp arg@[hp, aa,sa,da]
+ = gmpInteger2Int target res (hp, aa,sa,da)
-genPrimCode target res Addr2IntegerOp args = gmpString2Integer target res args
+ genprim [res] FloatEncodeOp args@[hp, aa,sa,da, expon] =
+ encodeFloatingKind FloatKind target res (hp, aa,sa,da, expon)
-genPrimCode target res FloatEncodeOp args =
- encodeFloatingKind FloatKind target res args
+ genprim [res] DoubleEncodeOp args@[hp, aa,sa,da, expon] =
+ encodeFloatingKind DoubleKind target res (hp, aa,sa,da, expon)
-genPrimCode target res DoubleEncodeOp args =
- encodeFloatingKind DoubleKind target res args
+ genprim [res] Int2AddrOp [arg] =
+ simpleCoercion AddrKind res arg
-genPrimCode target res FloatDecodeOp args =
- decodeFloatingKind FloatKind target res args
+ genprim [res] Addr2IntOp [arg] =
+ simpleCoercion IntKind res arg
-genPrimCode target res DoubleDecodeOp args =
- decodeFloatingKind DoubleKind target res args
+ genprim [res] Int2WordOp [arg] =
+ simpleCoercion IntKind{-WordKind?-} res arg
-genPrimCode target res Int2AddrOp arg =
- simpleCoercion target AddrKind res arg
+ genprim [res] Word2IntOp [arg] =
+ simpleCoercion IntKind res arg
+
+\end{code}
-genPrimCode target res Addr2IntOp 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@.
-genPrimCode target res Int2WordOp arg =
- simpleCoercion target IntKind{-WordKind?-} res arg
+\begin{code}
-genPrimCode target res Word2IntOp arg =
- simpleCoercion target IntKind res arg
+ genprim [] ErrorIOPrimOp [rhs] =
+ let changeTop = StAssign PtrKind topClosure (a2stix rhs)
+ in
+ returnSUs (\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]
+ genprim [res] NewArrayOp args =
+ let [liveness, n, initial] = map a2stix args
+ result = a2stix res
+ space = StPrim IntAddOp [n, mut_hs]
loc = StIndex PtrKind stgHp
(StPrim IntNegOp [StPrim IntSubOp [space, StInt 1]])
assign = StAssign PtrKind result loc
initialise = StCall SLIT("newArrZh_init") VoidKind [result, n, initial]
in
- heapCheck target liveness space (StInt 0)
- `thenSUs` \ heap_chk ->
+ heap_chkr 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]]
+ genprim [res] (NewByteArrayOp pk) args =
+ let [liveness, count] = map a2stix args
+ result = a2stix res
+ n = StPrim IntMulOp [count, StInt (toInteger (size_of pk))]
+ slop = StPrim IntAddOp [n, StInt (toInteger (size_of IntKind - 1))]
+ words = StPrim IntQuotOp [slop, StInt (toInteger (size_of IntKind))]
+ space = StPrim IntAddOp [n, StPrim IntAddOp [words, data_hs]]
loc = StIndex PtrKind stgHp
(StPrim IntNegOp [StPrim IntSubOp [space, StInt 1]])
assign = StAssign PtrKind result loc
init2 = StAssign IntKind
(StInd IntKind
(StIndex IntKind loc
- (StInt (toInteger (fixedHeaderSize target)))))
+ (StInt (toInteger fixed_hs))))
(StPrim IntAddOp [words,
- StInt (toInteger (varHeaderSize target
- (DataRep 0)))])
+ StInt (toInteger (var_hs (DataRep 0)))])
in
- heapCheck target liveness space (StInt 0)
- `thenSUs` \ heap_chk ->
+ heap_chkr liveness space (StInt 0) `thenSUs` \ heap_chk ->
returnSUs (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
+ genprim [res] SameMutableArrayOp args =
+ let compare = StPrim AddrEqOp (map a2stix args)
+ assign = StAssign IntKind (a2stix res) compare
in
returnSUs (\xs -> assign : xs)
-genPrimCode target res SameMutableByteArrayOp args =
- genPrimCode target res SameMutableArrayOp args
+ genprim res@[_] SameMutableByteArrayOp args =
+ genprim res SameMutableArrayOp args
\end{code}
\begin{code}
-genPrimCode target [lhs] UnsafeFreezeArrayOp [rhs] =
- let lhs' = amodeToStix target lhs
- rhs' = amodeToStix target rhs
+ genprim [lhs] UnsafeFreezeArrayOp [rhs] =
+ let lhs' = a2stix lhs
+ rhs' = a2stix rhs
header = StInd PtrKind lhs'
assign = StAssign PtrKind lhs' rhs'
freeze = StAssign PtrKind header imMutArrayOfPtrs_info
in
returnSUs (\xs -> assign : freeze : xs)
-genPrimCode target lhs UnsafeFreezeByteArrayOp rhs =
- simpleCoercion target PtrKind lhs rhs
+ genprim [lhs] UnsafeFreezeByteArrayOp [rhs] =
+ simpleCoercion PtrKind lhs rhs
\end{code}
\begin{code}
-genPrimCode target lhs IndexArrayOp args =
- genPrimCode target lhs ReadArrayOp args
+ genprim lhs@[_] IndexArrayOp args =
+ genprim 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)
+ genprim [lhs] ReadArrayOp [obj, ix] =
+ let lhs' = a2stix lhs
+ obj' = a2stix obj
+ ix' = a2stix ix
+ base = StIndex IntKind obj' mut_hs
assign = StAssign PtrKind lhs' (StInd PtrKind (StIndex PtrKind base ix'))
in
returnSUs (\xs -> assign : xs)
-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)
+ genprim [lhs] WriteArrayOp [obj, ix, v] =
+ let obj' = a2stix obj
+ ix' = a2stix ix
+ v' = a2stix v
+ base = StIndex IntKind obj' mut_hs
assign = StAssign PtrKind (StInd PtrKind (StIndex PtrKind base ix')) v'
in
returnSUs (\xs -> assign : xs)
-genPrimCode target lhs (IndexByteArrayOp pk) args =
- genPrimCode target lhs (ReadByteArrayOp pk) args
+ genprim lhs@[_] (IndexByteArrayOp pk) args =
+ genprim lhs (ReadByteArrayOp pk) args
+
+-- NB: indexing in "pk" units, *not* in bytes (WDP 95/09)
-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'))
+ genprim [lhs] (ReadByteArrayOp pk) [obj, ix] =
+ let lhs' = a2stix lhs
+ obj' = a2stix obj
+ ix' = a2stix ix
+ base = StIndex IntKind obj' data_hs
+ 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'
+ genprim [lhs] (IndexOffAddrOp pk) [obj, ix] =
+ let lhs' = a2stix lhs
+ obj' = a2stix obj
+ ix' = a2stix 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'))
+ genprim [] (WriteByteArrayOp pk) [obj, ix, v] =
+ let obj' = a2stix obj
+ ix' = a2stix ix
+ v' = a2stix v
+ base = StIndex IntKind obj' data_hs
+ assign = StAssign pk (StInd pk (StIndex pk base ix')) v'
in
returnSUs (\xs -> assign : xs)
-
\end{code}
Stable pointer operations.
\begin{code}
-genPrimCode target [lhs] DeRefStablePtrOp [sp] =
- let lhs' = amodeToStix target lhs
+ genprim [lhs] DeRefStablePtrOp [sp] =
+ let lhs' = a2stix lhs
pk = getAmodeKind lhs
- sp' = amodeToStix target sp
+ sp' = a2stix sp
call = StCall SLIT("deRefStablePointer") pk [sp', smStablePtrTable]
assign = StAssign pk lhs' call
in
--JSM
\begin{pseudocode}
-genPrimCode sty md [lhs] MakeStablePtrOp args =
+ genprim [lhs] MakeStablePtrOp args =
let
-- some useful abbreviations (I'm sure these must exist already)
add = trPrim . IntAddOp
(spt_EMPTY spt oklbl : (enlarge ++ (trLabel [oklbl] : allocate)))
\end{pseudocode}
+\begin{code}
+ genprim res Word2IntegerOp args = panic "genPrimCode:Word2IntegerOp"
+
+ genprim lhs (CCallOp fn is_asm may_gc arg_tys result_ty) rhs
+ | is_asm = error "ERROR: Native code generator can't handle casm"
+ | otherwise =
+ case lhs of
+ [] -> returnSUs (\xs -> (StCall fn VoidKind args) : xs)
+ [lhs] ->
+ let lhs' = a2stix lhs
+ pk = if isFloatingKind (getAmodeKind lhs) then DoubleKind else IntKind
+ call = StAssign pk lhs' (StCall fn pk args)
+ in
+ returnSUs (\xs -> call : xs)
+ where
+ args = map amodeCodeForCCall rhs
+ amodeCodeForCCall x =
+ let base = a2stix' x
+ in
+ case getAmodeKind x of
+ ArrayKind -> StIndex PtrKind base mut_hs
+ ByteArrayKind -> StIndex IntKind base data_hs
+ MallocPtrKind -> error "ERROR: native-code generator can't handle Malloc Ptrs (yet): use -fvia-C!"
+ _ -> base
+\end{code}
Now the more mundane operations.
\begin{code}
-
-genPrimCode target lhs op rhs =
- let lhs' = map (amodeToStix target) lhs
- rhs' = map (amodeToStix' target) rhs
+ genprim lhs op rhs =
+ let lhs' = map a2stix lhs
+ rhs' = map a2stix' 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)
+ returnSUs (\ xs -> simplePrim lhs' op rhs' : xs)
+
+ {-
+ simpleCoercion
+ :: Target
+ -> PrimKind
+ -> [CAddrMode]
+ -> [CAddrMode]
+ -> SUniqSM StixTreeList
+ -}
+ simpleCoercion pk lhs rhs =
+ returnSUs (\xs -> StAssign pk (a2stix lhs) (a2stix rhs) : xs)
\end{code}
at the level of the specific code generator.
\begin{code}
-
-simplePrim
+ {-
+ simplePrim
:: Target
-> [StixTree]
-> PrimOp
-> [StixTree]
-> StixTree
-
+ -}
\end{code}
Now look for something more conventional.
\begin{code}
-simplePrim target [lhs] op rest = StAssign pk lhs (StPrim op rest)
+ simplePrim [lhs] op rest = StAssign pk lhs (StPrim op rest)
where pk = if isCompareOp op then IntKind
else case getPrimOpResultInfo op of
ReturnsPrim pk -> pk
_ -> simplePrim_error op
-simplePrim 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")
+ 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")
\end{code}
%---------------------------------------------------------------------
-> CAddrMode
-> StixTree
-amodeCode' target am@(CVal rr CharKind)
+amodeCode'{-'-} target_STRICT 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_STRICT am
+ = acode am
+ where
+ -- grab "target" things:
+ hp_rel = hpRel target
+ char_like = charLikeClosureSize target
+ int_like = intLikeClosureSize target
+ a2stix = amodeToStix target
+
+ -- real code: ----------------------------------
+ acode am@(CVal rr CharKind) | mixedTypeLocn am =
+ StInd IntKind (acode (CAddr rr))
-amodeCode target (CVal rr pk) = StInd pk (amodeCode target (CAddr rr))
+ acode (CVal rr pk) = StInd pk (acode (CAddr rr))
-amodeCode target (CAddr r@(SpARel spA off)) =
- StIndex PtrKind stgSpA (StInt (toInteger (spARelToInt r)))
+ acode (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)))
+ acode (CAddr r@(SpBRel spB off)) =
+ StIndex IntKind stgSpB (StInt (toInteger (spBRelToInt r)))
-amodeCode target (CAddr (HpRel hp off)) =
- StIndex IntKind stgHp (StInt (toInteger (-(hpRel target (hp `subOff` off)))))
+ acode (CAddr (HpRel hp off)) =
+ StIndex IntKind stgHp (StInt (toInteger (-(hp_rel (hp `subOff` off)))))
-amodeCode target (CAddr (NodeRel off)) =
- StIndex IntKind stgNode (StInt (toInteger (hpRel target off)))
+ acode (CAddr (NodeRel off)) =
+ StIndex IntKind stgNode (StInt (toInteger (hp_rel off)))
-amodeCode target (CReg magic) = StReg (StixMagicId magic)
-amodeCode target (CTemp uniq pk) = StReg (StixTemp uniq pk)
+ acode (CReg magic) = StReg (StixMagicId magic)
+ acode (CTemp uniq pk) = StReg (StixTemp uniq pk)
-amodeCode target (CLbl lbl _) = StCLbl lbl
+ acode (CLbl lbl _) = StCLbl lbl
-amodeCode target (CUnVecLbl dir _) = StCLbl dir
+ acode (CUnVecLbl dir _) = StCLbl dir
-amodeCode target (CTableEntry base off pk) =
- StInd pk (StIndex pk (amodeCode target base) (amodeCode target off))
+ acode (CTableEntry base off pk) =
+ StInd pk (StIndex pk (acode base) (acode off))
--- For CharLike and IntLike, we attempt some trivial constant-folding here.
+ -- For CharLike and IntLike, we attempt some trivial constant-folding here.
-amodeCode target (CCharLike (CLit (MachChar c))) =
- StLitLbl (uppBeside (uppPStr SLIT("CHARLIKE_closures+")) (uppInt off))
- where off = charLikeClosureSize target * ord c
+ acode (CCharLike (CLit (MachChar c))) =
+ StLitLbl (uppBeside (uppPStr SLIT("CHARLIKE_closures+")) (uppInt off))
+ where off = char_like * ord c
-amodeCode target (CCharLike x) =
- StPrim IntAddOp [charLike, off]
- where off = StPrim IntMulOp [amodeCode target x,
- StInt (toInteger (charLikeClosureSize target))]
+ acode (CCharLike x) =
+ StPrim IntAddOp [charLike, off]
+ where off = StPrim IntMulOp [acode x,
+ StInt (toInteger (char_like))]
-amodeCode target (CIntLike (CLit (MachInt i _))) =
- StPrim IntAddOp [intLikePtr, StInt off]
- where off = toInteger (intLikeClosureSize target) * i
+ acode (CIntLike (CLit (MachInt i _))) =
+ StPrim IntAddOp [intLikePtr, StInt off]
+ where off = toInteger int_like * i
-amodeCode target (CIntLike x) =
- StPrim IntAddOp [intLikePtr, off]
- where off = StPrim IntMulOp [amodeCode target x,
- StInt (toInteger (intLikeClosureSize target))]
+ acode (CIntLike x) =
+ StPrim IntAddOp [intLikePtr, off]
+ where off = StPrim IntMulOp [acode x,
+ StInt (toInteger int_like)]
--- A CString is just a (CLit . MachStr)
-amodeCode target (CString s) = StString s
+ -- A CString is just a (CLit . MachStr)
+ acode (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"
+ acode (CLit core) = case core of
+ (MachChar c) -> StInt (toInteger (ord c))
+ (MachStr s) -> StString s
+ (MachAddr a) -> StInt a
+ (MachInt i _) -> StInt i
+ (MachLitLit s _) -> StLitLit s
+ (MachFloat d) -> StDouble d
+ (MachDouble d) -> StDouble d
+ _ -> panic "amodeCode:core literal"
--- A CLitLit is just a (CLit . MachLitLit)
-amodeCode target (CLitLit s _) = StLitLit s
+ -- A CLitLit is just a (CLit . MachLitLit)
+ acode (CLitLit s _) = StLitLit s
--- COffsets are in words, not bytes!
-amodeCode target (COffset off) = StInt (toInteger (hpRel target off))
+ -- COffsets are in words, not bytes!
+ acode (COffset off) = StInt (toInteger (hp_rel off))
-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]
- where
- tag = StInd IntKind (StIndex IntKind (amodeToStix target arg) (StInt (-2)))
- -- That ``-2'' really bothers me. (JSM)
+ acode (CMacroExpr _ macro [arg]) =
+ case macro of
+ INFO_PTR -> StInd PtrKind (a2stix arg)
+ ENTRY_CODE -> a2stix arg
+ INFO_TAG -> tag
+ EVAL_TAG -> StPrim IntGeOp [tag, StInt 0]
+ where
+ tag = StInd IntKind (StIndex IntKind (a2stix arg) (StInt (-2)))
+ -- That ``-2'' really bothers me. (JSM)
-amodeCode target (CCostCentre cc print_as_string)
- = if noCostCentreAttached cc
- then StComment SLIT("") -- sigh
- else panic "amodeCode:CCostCentre"
+ acode (CCostCentre cc print_as_string)
+ = if noCostCentreAttached cc
+ then StComment SLIT("") -- sigh
+ else panic "amodeCode:CCostCentre"
\end{code}
Sizes of the CharLike and IntLike closures that are arranged as arrays in the
projects / ghc-hetmet.git / blobdiff