%
-% (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, UniqSupply
- ) where
+import Ubiq{-uitous-}
+import NcgLoop -- paranoia checking only
-IMPORT_Trace -- ToDo: rm debugging
+import MachMisc
+import MachRegs
import AbsCSyn
-import PrelInfo ( PrimOp(..), PrimOpResultInfo(..), TyCon,
- getPrimOpResultInfo, isCompareOp, showPrimOp
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
- )
+import AbsCUtils ( getAmodeRep, mixedTypeLocn )
import CgCompInfo ( spARelToInt, spBRelToInt )
-import MachDesc
-import Pretty
-import PrimRep ( isFloatingRep )
-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 UniqSupply
-import Unpretty
-import Util
-
+import UniqSupply ( returnUs, thenUs, UniqSM(..) )
+import Unpretty ( uppBeside, uppPStr, uppInt )
+import Util ( panic )
\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
-> 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.
btw Why not let programmer use casm to provide assembly code instead
of C code? ADR
-\begin{code}
--- 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
-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.
+The (MP) integer operations are a true nightmare. Since we don't have
+a convenient abstract way of allocating temporary variables on the (C)
+stack, we use the space just below HpLim for the @MP_INT@ structures,
+and modify our heap check accordingly.
\begin{code}
- -- NB: ordering of clauses somewhere driven by
- -- the desire to getting sane patt-matching behavior
-
- 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)
+-- 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}
-Since we are using the heap for intermediate @MP_INT@ structs, integer comparison
-{\em does} require a heap check in the native code implementation.
+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 FloatRep target (exponr,ar,sr,dr) (hp, arg)
-
- genprim res@[exponr,ar,sr,dr] DoubleDecodeOp args@[hp, arg] =
- decodeFloatingKind DoubleRep target (exponr,ar,sr,dr) (hp, arg)
+primCode res@[exponr,ar,sr,dr] FloatDecodeOp args@[hp, arg]
+ = decodeFloatingKind FloatRep (exponr,ar,sr,dr) (hp, arg)
- genprim res@[ar,sr,dr] Int2IntegerOp args@[hp, n]
- = gmpInt2Integer target (ar,sr,dr) (hp, n)
+primCode res@[exponr,ar,sr,dr] DoubleDecodeOp args@[hp, arg]
+ = decodeFloatingKind DoubleRep (exponr,ar,sr,dr) (hp, arg)
- genprim res@[ar,sr,dr] Addr2IntegerOp args@[liveness,str]
- = gmpString2Integer target (ar,sr,dr) (liveness,str)
+primCode res@[ar,sr,dr] Int2IntegerOp args@[hp, n]
+ = gmpInt2Integer (ar,sr,dr) (hp, n)
- genprim [res] IntegerCmpOp args@[hp, aa1,sa1,da1, aa2,sa2,da2]
- = gmpCompare target res (hp, aa1,sa1,da1, aa2,sa2,da2)
+primCode res@[ar,sr,dr] Addr2IntegerOp args@[liveness,str]
+ = gmpString2Integer (ar,sr,dr) (liveness,str)
- genprim [res] Integer2IntOp arg@[hp, aa,sa,da]
- = gmpInteger2Int target res (hp, aa,sa,da)
+primCode [res] IntegerCmpOp args@[hp, aa1,sa1,da1, aa2,sa2,da2]
+ = gmpCompare res (hp, aa1,sa1,da1, aa2,sa2,da2)
- genprim [res] FloatEncodeOp args@[hp, aa,sa,da, expon] =
- encodeFloatingKind FloatRep target res (hp, aa,sa,da, expon)
+primCode [res] Integer2IntOp arg@[hp, aa,sa,da]
+ = gmpInteger2Int res (hp, aa,sa,da)
- genprim [res] DoubleEncodeOp args@[hp, aa,sa,da, expon] =
- encodeFloatingKind DoubleRep target res (hp, aa,sa,da, expon)
+primCode [res] FloatEncodeOp args@[hp, aa,sa,da, expon]
+ = encodeFloatingKind FloatRep res (hp, aa,sa,da, expon)
- genprim [res] Int2AddrOp [arg] =
- simpleCoercion AddrRep res arg
+primCode [res] DoubleEncodeOp args@[hp, aa,sa,da, expon]
+ = encodeFloatingKind DoubleRep res (hp, aa,sa,da, expon)
- genprim [res] Addr2IntOp [arg] =
- simpleCoercion IntRep res arg
+primCode [res] Int2AddrOp [arg]
+ = simpleCoercion AddrRep res arg
- genprim [res] Int2WordOp [arg] =
- simpleCoercion IntRep{-WordRep?-} res arg
+primCode [res] Addr2IntOp [arg]
+ = simpleCoercion IntRep res arg
- genprim [res] Word2IntOp [arg] =
- simpleCoercion IntRep res arg
+primCode [res] Int2WordOp [arg]
+ = simpleCoercion IntRep{-WordRep?-} res arg
+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@.
+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}
-
- genprim [] ErrorIOPrimOp [rhs] =
- let changeTop = StAssign PtrRep topClosure (a2stix rhs)
+primCode [] ErrorIOPrimOp [rhs]
+ = let
+ changeTop = StAssign PtrRep topClosure (amodeToStix rhs)
in
- returnUs (\xs -> changeTop : flushStdout : flushStderr : errorIO : xs)
-
+ returnUs (\xs -> changeTop : flushStdout : flushStderr : errorIO : xs)
\end{code}
@newArray#@ ops allocate heap space.
\begin{code}
- genprim [res] NewArrayOp args =
- let [liveness, n, initial] = map a2stix args
- result = a2stix res
- space = StPrim IntAddOp [n, mut_hs]
+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
- heap_chkr liveness space (StInt 0) `thenUs` \ heap_chk ->
-
- returnUs (heap_chk . (\xs -> assign : initialise : xs))
-
- 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 IntRep - 1))]
- words = StPrim IntQuotOp [slop, StInt (toInteger (size_of IntRep))]
- space = StPrim IntAddOp [n, StPrim IntAddOp [words, data_hs]]
+ 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
init2 = StAssign IntRep
(StInd IntRep
(StIndex IntRep loc
- (StInt (toInteger fixed_hs))))
+ (StInt (toInteger fixedHdrSizeInWords))))
(StPrim IntAddOp [words,
- StInt (toInteger (var_hs (DataRep 0)))])
+ StInt (toInteger (varHdrSizeInWords (DataRep 0)))])
in
- heap_chkr liveness space (StInt 0) `thenUs` \ heap_chk ->
+ heapCheck liveness space (StInt 0) `thenUs` \ heap_chk ->
- returnUs (heap_chk . (\xs -> assign : init1 : init2 : xs))
+ returnUs (heap_chk . (\xs -> assign : init1 : init2 : xs))
- genprim [res] SameMutableArrayOp args =
- let compare = StPrim AddrEqOp (map a2stix args)
- assign = StAssign IntRep (a2stix res) compare
+primCode [res] SameMutableArrayOp args
+ = let
+ compare = StPrim AddrEqOp (map amodeToStix args)
+ assign = StAssign IntRep (amodeToStix res) compare
in
- returnUs (\xs -> assign : xs)
-
- genprim res@[_] SameMutableByteArrayOp args =
- genprim 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}
- genprim [lhs] UnsafeFreezeArrayOp [rhs] =
- let lhs' = a2stix lhs
- rhs' = a2stix rhs
+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
- returnUs (\xs -> assign : freeze : xs)
-
- genprim [lhs] UnsafeFreezeByteArrayOp [rhs] =
- simpleCoercion PtrRep 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}
- genprim lhs@[_] IndexArrayOp args =
- genprim lhs ReadArrayOp args
+primCode lhs@[_] IndexArrayOp args
+ = primCode lhs ReadArrayOp args
- genprim [lhs] ReadArrayOp [obj, ix] =
- let lhs' = a2stix lhs
- obj' = a2stix obj
- ix' = a2stix ix
- base = StIndex IntRep obj' mut_hs
+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
- returnUs (\xs -> assign : xs)
-
- genprim [lhs] WriteArrayOp [obj, ix, v] =
- let obj' = a2stix obj
- ix' = a2stix ix
- v' = a2stix v
- base = StIndex IntRep obj' mut_hs
+ 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
- returnUs (\xs -> assign : xs)
+ returnUs (\xs -> assign : xs)
- genprim lhs@[_] (IndexByteArrayOp pk) args =
- genprim lhs (ReadByteArrayOp pk) args
+primCode lhs@[_] (IndexByteArrayOp pk) args
+ = primCode lhs (ReadByteArrayOp pk) args
-- NB: indexing in "pk" units, *not* in bytes (WDP 95/09)
- genprim [lhs] (ReadByteArrayOp pk) [obj, ix] =
- let lhs' = a2stix lhs
- obj' = a2stix obj
- ix' = a2stix ix
- base = StIndex IntRep obj' data_hs
+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
- returnUs (\xs -> assign : xs)
+ returnUs (\xs -> assign : xs)
- genprim [lhs] (IndexOffAddrOp pk) [obj, ix] =
- let lhs' = a2stix lhs
- obj' = a2stix obj
- ix' = a2stix ix
+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
- returnUs (\xs -> assign : xs)
-
- genprim [] (WriteByteArrayOp pk) [obj, ix, v] =
- let obj' = a2stix obj
- ix' = a2stix ix
- v' = a2stix v
- base = StIndex IntRep obj' data_hs
+ 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
- returnUs (\xs -> assign : xs)
+ returnUs (\xs -> assign : xs)
\end{code}
Stable pointer operations.
First the easy one.
-
\begin{code}
- genprim [lhs] DeRefStablePtrOp [sp] =
- let lhs' = a2stix lhs
+primCode [lhs] DeRefStablePtrOp [sp]
+ = let
+ lhs' = amodeToStix lhs
pk = getAmodeRep lhs
- sp' = a2stix sp
+ sp' = amodeToStix sp
call = StCall SLIT("deRefStablePointer") pk [sp', smStablePtrTable]
assign = StAssign pk lhs' call
in
- returnUs (\xs -> assign : xs)
-
+ returnUs (\xs -> assign : xs)
\end{code}
Now the hard one. For comparison, here's the code from StgMacros:
--JSM
\begin{pseudocode}
- genprim [lhs] MakeStablePtrOp args =
- let
+primCode [lhs] MakeStablePtrOp args
+ = let
-- some useful abbreviations (I'm sure these must exist already)
add = trPrim . IntAddOp
sub = trPrim . IntSubOp
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
+ 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]]
]
-- 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
\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
- [] -> returnUs (\xs -> (StCall fn VoidRep args) : xs)
- [lhs] ->
- let lhs' = a2stix 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 = a2stix' x
- in
- case getAmodeRep x of
- ArrayRep -> StIndex PtrRep base mut_hs
- ByteArrayRep -> StIndex IntRep base data_hs
- MallocPtrRep -> error "ERROR: native-code generator can't handle Malloc Ptrs (yet): use -fvia-C!"
- _ -> base
+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
+ MallocPtrRep -> error "ERROR: native-code generator can't handle Malloc Ptrs (yet): use -fvia-C!"
+ _ -> base
\end{code}
Now the more mundane operations.
\begin{code}
- genprim lhs op rhs =
- let lhs' = map a2stix lhs
- rhs' = map a2stix' rhs
+primCode lhs op rhs
+ = let
+ lhs' = map amodeToStix lhs
+ rhs' = map amodeToStix' rhs
in
- returnUs (\ xs -> simplePrim lhs' op rhs' : xs)
-
- {-
- simpleCoercion
- :: Target
- -> PrimRep
- -> [CAddrMode]
- -> [CAddrMode]
+ 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 (a2stix lhs) (a2stix rhs) : xs)
+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]
+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 _ op _ = simplePrim_error op
-
- simplePrim_error op
+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_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}
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_STRICT am@(CVal rr CharRep)
- | mixedTypeLocn am = StPrim ChrOp [amodeToStix target am]
- | otherwise = amodeToStix target am
-
-amodeCode' target am = amodeToStix target am
+amodeToStix'{-'-} am@(CVal rr CharRep)
+ | mixedTypeLocn am = StPrim ChrOp [amodeToStix am]
+ | otherwise = amodeToStix am
-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
+amodeToStix' am = amodeToStix am
- -- real code: ----------------------------------
- acode am@(CVal rr CharRep) | mixedTypeLocn am =
- StInd IntRep (acode (CAddr rr))
+-----------
+amodeToStix am@(CVal rr CharRep)
+ | mixedTypeLocn am
+ = StInd IntRep (amodeToStix (CAddr rr))
- acode (CVal rr pk) = StInd pk (acode (CAddr rr))
+amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
- acode (CAddr (SpARel spA off)) =
- StIndex PtrRep stgSpA (StInt (toInteger (spARelToInt spA off)))
+amodeToStix (CAddr (SpARel spA off))
+ = StIndex PtrRep stgSpA (StInt (toInteger (spARelToInt spA off)))
- acode (CAddr (SpBRel spB off)) =
- StIndex IntRep stgSpB (StInt (toInteger (spBRelToInt spB off)))
+amodeToStix (CAddr (SpBRel spB off))
+ = StIndex IntRep stgSpB (StInt (toInteger (spBRelToInt spB off)))
- acode (CAddr (HpRel hp off)) =
- StIndex IntRep stgHp (StInt (toInteger (-(hp_rel (hp `subOff` off)))))
+amodeToStix (CAddr (HpRel hp off))
+ = StIndex IntRep stgHp (StInt (toInteger (-(hpRelToInt (hp `subOff` off)))))
- acode (CAddr (NodeRel off)) =
- StIndex IntRep stgNode (StInt (toInteger (hp_rel off)))
+amodeToStix (CAddr (NodeRel off))
+ = StIndex IntRep stgNode (StInt (toInteger (hpRelToInt off)))
- acode (CReg magic) = StReg (StixMagicId magic)
- acode (CTemp uniq pk) = StReg (StixTemp uniq pk)
+amodeToStix (CReg magic) = StReg (StixMagicId magic)
+amodeToStix (CTemp uniq pk) = StReg (StixTemp uniq pk)
- acode (CLbl lbl _) = StCLbl lbl
+amodeToStix (CLbl lbl _) = StCLbl lbl
+amodeToStix (CUnVecLbl dir _) = StCLbl dir
- acode (CUnVecLbl dir _) = StCLbl dir
-
- acode (CTableEntry base off pk) =
- StInd pk (StIndex pk (acode base) (acode off))
+amodeToStix (CTableEntry base off pk)
+ = StInd pk (StIndex pk (amodeToStix base) (amodeToStix off))
-- For CharLike and IntLike, we attempt some trivial constant-folding here.
- acode (CCharLike (CLit (MachChar c))) =
- StLitLbl (uppBeside (uppPStr SLIT("CHARLIKE_closures+")) (uppInt off))
- where off = char_like * ord c
+amodeToStix (CCharLike (CLit (MachChar c)))
+ = StLitLbl (uppBeside (uppPStr SLIT("CHARLIKE_closures+")) (uppInt off))
+ where
+ off = charLikeSize * ord c
- acode (CCharLike x) =
- StPrim IntAddOp [charLike, off]
- where off = StPrim IntMulOp [acode x,
- StInt (toInteger (char_like))]
+amodeToStix (CCharLike x)
+ = StPrim IntAddOp [charLike, off]
+ where
+ off = StPrim IntMulOp [amodeToStix x, StInt (toInteger charLikeSize)]
- acode (CIntLike (CLit (MachInt i _))) =
- StPrim IntAddOp [intLikePtr, StInt off]
- where off = toInteger int_like * i
+amodeToStix (CIntLike (CLit (MachInt i _)))
+ = StPrim IntAddOp [intLikePtr, StInt off]
+ where
+ off = toInteger intLikeSize * i
- acode (CIntLike x) =
- StPrim IntAddOp [intLikePtr, off]
- where off = StPrim IntMulOp [acode x,
- StInt (toInteger int_like)]
+amodeToStix (CIntLike x)
+ = StPrim IntAddOp [intLikePtr, off]
+ where
+ off = StPrim IntMulOp [amodeToStix x, StInt (toInteger intLikeSize)]
-- A CString is just a (CLit . MachStr)
- acode (CString s) = StString s
-
- 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"
+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)
- acode (CLitLit s _) = StLitLit s
+amodeToStix (CLitLit s _) = StLitLit s
-- COffsets are in words, not bytes!
- acode (COffset off) = StInt (toInteger (hp_rel off))
-
- acode (CMacroExpr _ macro [arg]) =
- case macro of
- INFO_PTR -> StInd PtrRep (a2stix arg)
- ENTRY_CODE -> a2stix arg
- INFO_TAG -> tag
- EVAL_TAG -> StPrim IntGeOp [tag, StInt 0]
+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 (a2stix arg) (StInt (-2)))
- -- That ``-2'' really bothers me. (JSM)
+ tag = StInd IntRep (StIndex IntRep (amodeToStix arg) (StInt (-2)))
+ -- That ``-2'' really bothers me. (JSM) (Replace w/ oTHER_TAG? [WDP])
- acode (CCostCentre cc print_as_string)
- = if noCostCentreAttached cc
- then StComment SLIT("") -- sigh
- else panic "amodeCode:CCostCentre"
+amodeToStix (CCostCentre cc print_as_string)
+ = if noCostCentreAttached cc
+ then StComment SLIT("") -- sigh
+ 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
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}
projects / ghc-hetmet.git / blobdiff