diff options
33 files changed, 2918 insertions, 2294 deletions
diff --git a/ghc/compiler/absCSyn/AbsCSyn.lhs b/ghc/compiler/absCSyn/AbsCSyn.lhs index 977027d5c1..a850a9f8e9 100644 --- a/ghc/compiler/absCSyn/AbsCSyn.lhs +++ b/ghc/compiler/absCSyn/AbsCSyn.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: AbsCSyn.lhs,v 1.40 2001/11/23 11:58:00 simonmar Exp $ +% $Id: AbsCSyn.lhs,v 1.41 2001/12/05 17:35:12 sewardj Exp $ % \section[AbstractC]{Abstract C: the last stop before machine code} @@ -47,12 +47,15 @@ import CostCentre ( CostCentre, CostCentreStack ) import Literal ( mkMachInt, Literal(..) ) import ForeignCall ( CCallSpec ) import PrimRep ( PrimRep(..) ) +import MachOp ( MachOp(..) ) import Unique ( Unique ) import StgSyn ( StgOp ) import TyCon ( TyCon ) import BitSet -- for liveness masks +import Maybes ( Maybe012(..) ) import FastTypes +import Outputable \end{code} @AbstractC@ is a list of Abstract~C statements, but the data structure @@ -117,6 +120,25 @@ stored in a mixed type location.) -- CReg CurCostCentre or CC_HDR(R1.p{-Node-}) Int -- size of closure, for profiling + -- NEW CASES FOR EXPANDED PRIMOPS + + | CMachOpStmt -- Machine-level operation + (Maybe012 CAddrMode) -- 0, 1 or 2 results + MachOp + [CAddrMode] -- Arguments + (Maybe [MagicId]) -- list of regs which need to be preserved + -- across the primop. This is allowed to be Nothing only if + -- machOpIsDefinitelyInline returns True. And that in turn may + -- only return True if we are absolutely sure that the mach op + -- can be done inline on all platforms. + + | CSequential -- Do the nested AbstractCs sequentially. + [AbstractC] -- In particular, as far as the AbsCUtils.doSimultaneously + -- is concerned, these stmts are to be treated as atomic + -- and are not to be reordered. + + -- end of NEW CASES FOR EXPANDED PRIMOPS + | COpStmt [CAddrMode] -- Results StgOp @@ -349,6 +371,9 @@ data CAddrMode !PrimRep -- the kind of the result CExprMacro -- the macro to generate a value [CAddrMode] -- and its arguments + + | CMem PrimRep -- A value :: PrimRep, in memory, at the + CAddrMode -- specified address \end{code} Various C macros for values which are dependent on the back-end layout. diff --git a/ghc/compiler/absCSyn/AbsCUtils.lhs b/ghc/compiler/absCSyn/AbsCUtils.lhs index 2d55bd0720..46dc512f27 100644 --- a/ghc/compiler/absCSyn/AbsCUtils.lhs +++ b/ghc/compiler/absCSyn/AbsCUtils.lhs @@ -13,27 +13,34 @@ module AbsCUtils ( mixedTypeLocn, mixedPtrLocn, flattenAbsC, mkAbsCStmtList - -- printing/forcing stuff comes from PprAbsC ) where #include "HsVersions.h" import AbsCSyn +import CLabel ( mkMAP_FROZEN_infoLabel ) import Digraph ( stronglyConnComp, SCC(..) ) import DataCon ( fIRST_TAG, ConTag ) -import Literal ( literalPrimRep, mkMachWord ) +import Literal ( literalPrimRep, mkMachWord, mkMachInt ) import PrimRep ( getPrimRepSize, PrimRep(..) ) +import PrimOp ( PrimOp(..) ) +import MachOp ( MachOp(..), isDefinitelyInlineMachOp ) import Unique ( Unique{-instance Eq-} ) import UniqSupply ( uniqFromSupply, uniqsFromSupply, splitUniqSupply, UniqSupply ) import CmdLineOpts ( opt_EmitCExternDecls ) -import ForeignCall ( ForeignCall(..), CCallSpec(..), isDynamicTarget, isCasmTarget ) +import ForeignCall ( ForeignCall(..), CCallSpec(..), CCallTarget(..), Safety(..), + isDynamicTarget, isCasmTarget, defaultCCallConv ) import StgSyn ( StgOp(..) ) +import SMRep ( arrPtrsHdrSize, arrWordsHdrSize, fixedHdrSize ) +import Constants ( wORD_SIZE ) +import Maybes ( Maybe012(..) ) +import Outputable import Panic ( panic ) import FastTypes -import Maybe ( isJust ) +import Maybe ( isJust, maybeToList ) infixr 9 `thenFlt` \end{code} @@ -171,6 +178,7 @@ getAmodeRep (CIntLike _) = PtrRep getAmodeRep (CLit lit) = literalPrimRep lit getAmodeRep (CMacroExpr kind _ _) = kind getAmodeRep (CJoinPoint _) = panic "getAmodeRep:CJoinPoint" +getAmodeRep (CMem rep addr) = rep \end{code} @mixedTypeLocn@ tells whether an amode identifies an ``StgWord'' @@ -342,8 +350,8 @@ flatAbsC (CSwitch discrim alts deflt) returnFlt ( (tag, alt_heres), alt_tops ) flatAbsC stmt@(COpStmt results (StgFCallOp (CCall ccall@(CCallSpec target _ _)) uniq) args _) - | is_dynamic -- Emit a typedef if its a dynamic call - || (opt_EmitCExternDecls && not (isCasmTarget target)) -- or we want extern decls + | is_dynamic -- Emit a typedef if its a dynamic call + || (opt_EmitCExternDecls && not (isCasmTarget target)) -- or we want extern decls = returnFlt (stmt, CCallTypedef is_dynamic ccall uniq results args) where is_dynamic = isDynamicTarget target @@ -370,8 +378,44 @@ flatAbsC stmt@(CAssign dest source) = returnFlt (stmt, AbsCNop) flatAbsC stmt@(CJump target) = returnFlt (stmt, AbsCNop) flatAbsC stmt@(CFallThrough target) = returnFlt (stmt, AbsCNop) flatAbsC stmt@(CReturn target return_info) = returnFlt (stmt, AbsCNop) -flatAbsC stmt@(CInitHdr a b cc _) = returnFlt (stmt, AbsCNop) -flatAbsC stmt@(COpStmt results op args vol_regs) = returnFlt (stmt, AbsCNop) +flatAbsC stmt@(CInitHdr a b cc sz) = returnFlt (stmt, AbsCNop) +flatAbsC stmt@(CMachOpStmt res mop args m_vols) = returnFlt (stmt, AbsCNop) +flatAbsC stmt@(COpStmt results (StgFCallOp _ _) args vol_regs) + = returnFlt (stmt, AbsCNop) +flatAbsC stmt@(COpStmt results (StgPrimOp op) args vol_regs) + = dscCOpStmt (filter non_void_amode results) op + (filter non_void_amode args) vol_regs + `thenFlt` \ simpl -> + case simpl of + COpStmt _ _ _ _ -> panic "flatAbsC - dscCOpStmt" -- make sure we don't loop! + other -> flatAbsC other + {- + A gruesome hack for printing the names of inline primops when they + are used. + oink other + where + oink xxx + = getUniqFlt `thenFlt` \ uu -> + flatAbsC (CSequential [moo uu (showSDoc (ppr op)), xxx]) + + moo uu op_str + = COpStmt + [] + (StgFCallOp + (CCall (CCallSpec (CasmTarget (_PK_ (mktxt op_str))) + defaultCCallConv PlaySafe)) + uu + ) + [CReg VoidReg] + [] + mktxt op_str + = " asm(\"pushal;\"); printf(\"%%s\\n\",\"" ++ op_str ++ "\"); asm(\"popal\"); " + -} + +flatAbsC (CSequential abcs) + = mapAndUnzipFlt flatAbsC abcs `thenFlt` \ (inlines, tops) -> + returnFlt (CSequential inlines, foldr AbsCStmts AbsCNop tops) + -- Some statements only make sense at the top level, so we always float -- them. This probably isn't necessary. @@ -493,7 +537,6 @@ doSimultaneously1 vertices = or [dest1 `conflictsWith` src2 | dest1 <- dests1, src2 <- srcs2] \end{code} - @conflictsWith@ tells whether an assignment to its first argument will screw up an access to its second. @@ -540,3 +583,546 @@ rrConflictsWithRR s1b s2b rr1 rr2 = rr rr1 rr2 rr other1 other2 = False \end{code} + +%************************************************************************ +%* * +\subsection[flat-primops]{Translating COpStmts to CMachOpStmts} +%* * +%************************************************************************ + +\begin{code} + + +------------------------------------------------------------------------------ + +-- Assumes no volatiles +mkHalfWord_HIADDR res arg +# if WORDS_BIGENDIAN + = CMachOpStmt (Just1 res) MO_Nat_And [arg, CLit (mkMachWord halfword_mask)] Nothing +# else + = CMachOpStmt (Just1 res) MO_Nat_Shr [arg, CLit (mkMachWord halfword_shift)] Nothing +# endif + where + (halfword_mask, halfword_shift) + | wORD_SIZE == 4 = (65535, 16) + | wORD_SIZE == 8 = (4294967295::Integer, 32) + + +mkTemp :: PrimRep -> FlatM CAddrMode +mkTemp rep + = getUniqFlt `thenFlt` \ uniq -> returnFlt (CTemp uniq rep) + +mkTemps = mapFlt mkTemp + +mkDerefOff :: PrimRep -> CAddrMode -> Int -> CAddrMode +mkDerefOff rep base off + | off == 0 -- optimisation + = CMem rep base + | otherwise + = CMem rep (CAddr (CIndex base (CLit (mkMachInt (toInteger off))) rep)) + +mkNoDerefOff :: PrimRep -> CAddrMode -> Int -> CAddrMode +mkNoDerefOff rep base off + = CAddr (CIndex base (CLit (mkMachInt (toInteger off))) rep) + +-- Sigh. This is done in 3 seperate places. Should be +-- commoned up (here, in pprAbsC of COpStmt, and presumably +-- somewhere in the NCG). +non_void_amode amode + = case getAmodeRep amode of + VoidRep -> False + k -> True + +doIndexOffForeignObjOp rep res addr idx + = Just (Just1 res, MO_ReadOSBI fixedHdrSize rep, [addr,idx]) + +doIndexOffAddrOp rep res addr idx + = Just (Just1 res, MO_ReadOSBI 0 rep, [addr,idx]) + +doIndexByteArrayOp rep res addr idx + = Just (Just1 res, MO_ReadOSBI arrWordsHdrSize rep, [addr,idx]) + +doWriteOffAddrOp rep addr idx val + = Just (Just0, MO_WriteOSBI 0 rep, [addr,idx,val]) + +doWriteByteArrayOp rep addr idx val + = Just (Just0, MO_WriteOSBI arrWordsHdrSize rep, [addr,idx,val]) + +-- Simple dyadic op but one for which we need to cast first arg to +-- be sure of correctness +translateOp_dyadic_cast1 mop res cast_arg1_to arg1 arg2 vols + = mkTemp cast_arg1_to `thenFlt` \ arg1casted -> + (returnFlt . CSequential) [ + CAssign arg1casted arg1, + CMachOpStmt (Just1 res) mop [arg1casted,arg2] + (if isDefinitelyInlineMachOp mop then Nothing else Just vols) + ] + +------------------------------------------------------------------------------ + +dscCOpStmt :: [CAddrMode] -- Results + -> PrimOp + -> [CAddrMode] -- Arguments + -> [MagicId] -- Potentially volatile/live registers + -- (to save/restore around the op) + -> FlatM AbstractC + +-- #define parzh(r,node) r = 1 +dscCOpStmt [res] ParOp [arg] vols + = returnFlt + (CAssign res (CLit (mkMachInt 1))) + +-- #define readMutVarzh(r,a) r=(P_)(((StgMutVar *)(a))->var) +dscCOpStmt [res] ReadMutVarOp [mutv] vols + = returnFlt + (CAssign res (mkDerefOff PtrRep mutv fixedHdrSize)) + +-- #define writeMutVarzh(a,v) (P_)(((StgMutVar *)(a))->var)=(v) +dscCOpStmt [] WriteMutVarOp [mutv,var] vols + = returnFlt + (CAssign (mkDerefOff PtrRep mutv fixedHdrSize) var) + + +-- #define ForeignObj_CLOSURE_DATA(c) (((StgForeignObj *)c)->data) +-- #define foreignObjToAddrzh(r,fo) r=ForeignObj_CLOSURE_DATA(fo) +dscCOpStmt [res] ForeignObjToAddrOp [fo] vols + = returnFlt + (CAssign res (mkDerefOff PtrRep fo fixedHdrSize)) + +-- #define writeForeignObjzh(res,datum) \ +-- (ForeignObj_CLOSURE_DATA(res) = (P_)(datum)) +dscCOpStmt [] WriteForeignObjOp [fo,addr] vols + = returnFlt + (CAssign (mkDerefOff PtrRep fo fixedHdrSize) addr) + + +-- #define sizzeofByteArrayzh(r,a) \ +-- r = (((StgArrWords *)(a))->words * sizeof(W_)) +dscCOpStmt [res] SizeofByteArrayOp [arg] vols + = mkTemp WordRep `thenFlt` \ w -> + (returnFlt . CSequential) [ + CAssign w (mkDerefOff WordRep arg fixedHdrSize), + CMachOpStmt (Just1 w) + MO_NatU_Mul [w, CLit (mkMachInt (toInteger wORD_SIZE))] (Just vols), + CAssign res w + ] + +-- #define sizzeofMutableByteArrayzh(r,a) \ +-- r = (((StgArrWords *)(a))->words * sizeof(W_)) +dscCOpStmt [res] SizeofMutableByteArrayOp [arg] vols + = dscCOpStmt [res] SizeofByteArrayOp [arg] vols + + +-- #define touchzh(o) /* nothing */ +dscCOpStmt [] TouchOp [arg] vols + = returnFlt AbsCNop + +-- #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a) +dscCOpStmt [res] ByteArrayContents_Char [arg] vols + = mkTemp PtrRep `thenFlt` \ ptr -> + (returnFlt . CSequential) [ + CMachOpStmt (Just1 ptr) MO_NatU_to_NatP [arg] Nothing, + CAssign ptr (mkNoDerefOff WordRep ptr arrWordsHdrSize), + CAssign res ptr + ] + +-- #define stableNameToIntzh(r,s) (r = ((StgStableName *)s)->sn) +dscCOpStmt [res] StableNameToIntOp [arg] vols + = returnFlt + (CAssign res (mkDerefOff WordRep arg fixedHdrSize)) + +-- #define eqStableNamezh(r,sn1,sn2) \ +-- (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn)) +dscCOpStmt [res] EqStableNameOp [arg1,arg2] vols + = mkTemps [WordRep, WordRep] `thenFlt` \ [sn1,sn2] -> + (returnFlt . CSequential) [ + CAssign sn1 (mkDerefOff WordRep arg1 fixedHdrSize), + CAssign sn2 (mkDerefOff WordRep arg2 fixedHdrSize), + CMachOpStmt (Just1 res) MO_Nat_Eq [sn1,sn2] Nothing + ] + +-- #define addrToHValuezh(r,a) r=(P_)a +dscCOpStmt [res] AddrToHValueOp [arg] vols + = returnFlt + (CAssign res arg) + +-- #define dataToTagzh(r,a) r=(GET_TAG(((StgClosure *)a)->header.info)) +dscCOpStmt [res] DataToTagOp [arg] vols + = mkTemps [PtrRep, WordRep] `thenFlt` \ [t_infoptr, t_theword] -> + (returnFlt . CSequential) [ + CAssign t_infoptr (mkDerefOff PtrRep arg 0), + CAssign t_theword (mkDerefOff WordRep t_infoptr (-1)), + mkHalfWord_HIADDR res t_theword + ] + + +{- Freezing arrays-of-ptrs requires changing an info table, for the + benefit of the generational collector. It needs to scavenge mutable + objects, even if they are in old space. When they become immutable, + they can be removed from this scavenge list. -} + +-- #define unsafeFreezzeArrayzh(r,a) \ +-- { \ +-- SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN_info); \ +-- r = a; \ +-- } +dscCOpStmt [res] UnsafeFreezeArrayOp [arg] vols + = (returnFlt . CSequential) [ + CAssign (mkDerefOff PtrRep arg 0) (CLbl mkMAP_FROZEN_infoLabel PtrRep), + CAssign res arg + ] + +-- #define unsafeFreezzeByteArrayzh(r,a) r=(a) +dscCOpStmt [res] UnsafeFreezeByteArrayOp [arg] vols + = returnFlt + (CAssign res arg) + +-- This ought to be trivial, but it's difficult to insert the casts +-- required to keep the C compiler happy. +dscCOpStmt [r] AddrRemOp [a1,a2] vols + = mkTemp WordRep `thenFlt` \ a1casted -> + (returnFlt . CSequential) [ + CMachOpStmt (Just1 a1casted) MO_NatP_to_NatU [a1] Nothing, + CMachOpStmt (Just1 r) MO_NatU_Rem [a1casted,a2] Nothing + ] + +-- not handled by translateOp because they need casts +dscCOpStmt [r] SllOp [a1,a2] vols + = translateOp_dyadic_cast1 MO_Nat_Shl r WordRep a1 a2 vols +dscCOpStmt [r] SrlOp [a1,a2] vols + = translateOp_dyadic_cast1 MO_Nat_Shr r WordRep a1 a2 vols + +dscCOpStmt [r] ISllOp [a1,a2] vols + = translateOp_dyadic_cast1 MO_Nat_Shl r IntRep a1 a2 vols +dscCOpStmt [r] ISrlOp [a1,a2] vols + = translateOp_dyadic_cast1 MO_Nat_Shr r IntRep a1 a2 vols +dscCOpStmt [r] ISraOp [a1,a2] vols + = translateOp_dyadic_cast1 MO_Nat_Sar r IntRep a1 a2 vols + + +-- Handle all others as simply as possible. +dscCOpStmt ress op args vols + = case translateOp ress op args of + Nothing + -> pprPanic "dscCOpStmt: can't translate PrimOp" (ppr op) + Just (maybe_res, mop, args) + -> returnFlt ( + CMachOpStmt maybe_res mop args + (if isDefinitelyInlineMachOp mop then Nothing else Just vols) + ) + + + +translateOp [r] ReadArrayOp [obj,ix] + = Just (Just1 r, MO_ReadOSBI arrPtrsHdrSize PtrRep, [obj,ix]) +translateOp [r] IndexArrayOp [obj,ix] + = Just (Just1 r, MO_ReadOSBI arrPtrsHdrSize PtrRep, [obj,ix]) +translateOp [] WriteArrayOp [obj,ix,v] + = Just (Just0, MO_WriteOSBI arrPtrsHdrSize PtrRep, [obj,ix,v]) + +-- IndexXXXoffForeignObj + +translateOp [r] IndexOffForeignObjOp_Char [a,i] = doIndexOffForeignObjOp Word8Rep r a i +translateOp [r] IndexOffForeignObjOp_WideChar [a,i] = doIndexOffForeignObjOp Word32Rep r a i +translateOp [r] IndexOffForeignObjOp_Int [a,i] = doIndexOffForeignObjOp IntRep r a i +translateOp [r] IndexOffForeignObjOp_Word [a,i] = doIndexOffForeignObjOp WordRep r a i +translateOp [r] IndexOffForeignObjOp_Addr [a,i] = doIndexOffForeignObjOp AddrRep r a i +translateOp [r] IndexOffForeignObjOp_Float [a,i] = doIndexOffForeignObjOp FloatRep r a i +translateOp [r] IndexOffForeignObjOp_Double [a,i] = doIndexOffForeignObjOp DoubleRep r a i +translateOp [r] IndexOffForeignObjOp_StablePtr [a,i] = doIndexOffForeignObjOp StablePtrRep r a i + +translateOp [r] IndexOffForeignObjOp_Int8 [a,i] = doIndexOffForeignObjOp Int8Rep r a i +translateOp [r] IndexOffForeignObjOp_Int16 [a,i] = doIndexOffForeignObjOp Int16Rep r a i +translateOp [r] IndexOffForeignObjOp_Int32 [a,i] = doIndexOffForeignObjOp Int32Rep r a i +translateOp [r] IndexOffForeignObjOp_Int64 [a,i] = doIndexOffForeignObjOp Int64Rep r a i + +translateOp [r] IndexOffForeignObjOp_Word8 [a,i] = doIndexOffForeignObjOp Word8Rep r a i +translateOp [r] IndexOffForeignObjOp_Word16 [a,i] = doIndexOffForeignObjOp Word16Rep r a i +translateOp [r] IndexOffForeignObjOp_Word32 [a,i] = doIndexOffForeignObjOp Word32Rep r a i +translateOp [r] IndexOffForeignObjOp_Word64 [a,i] = doIndexOffForeignObjOp Word64Rep r a i + +-- IndexXXXoffAddr + +translateOp [r] IndexOffAddrOp_Char [a,i] = doIndexOffAddrOp Word8Rep r a i +translateOp [r] IndexOffAddrOp_WideChar [a,i] = doIndexOffAddrOp Word32Rep r a i +translateOp [r] IndexOffAddrOp_Int [a,i] = doIndexOffAddrOp IntRep r a i +translateOp [r] IndexOffAddrOp_Word [a,i] = doIndexOffAddrOp WordRep r a i +translateOp [r] IndexOffAddrOp_Addr [a,i] = doIndexOffAddrOp AddrRep r a i +translateOp [r] IndexOffAddrOp_Float [a,i] = doIndexOffAddrOp FloatRep r a i +translateOp [r] IndexOffAddrOp_Double [a,i] = doIndexOffAddrOp DoubleRep r a i +translateOp [r] IndexOffAddrOp_StablePtr [a,i] = doIndexOffAddrOp StablePtrRep r a i + +translateOp [r] IndexOffAddrOp_Int8 [a,i] = doIndexOffAddrOp Int8Rep r a i +translateOp [r] IndexOffAddrOp_Int16 [a,i] = doIndexOffAddrOp Int16Rep r a i +translateOp [r] IndexOffAddrOp_Int32 [a,i] = doIndexOffAddrOp Int32Rep r a i +translateOp [r] IndexOffAddrOp_Int64 [a,i] = doIndexOffAddrOp Int64Rep r a i + +translateOp [r] IndexOffAddrOp_Word8 [a,i] = doIndexOffAddrOp Word8Rep r a i +translateOp [r] IndexOffAddrOp_Word16 [a,i] = doIndexOffAddrOp Word16Rep r a i +translateOp [r] IndexOffAddrOp_Word32 [a,i] = doIndexOffAddrOp Word32Rep r a i +translateOp [r] IndexOffAddrOp_Word64 [a,i] = doIndexOffAddrOp Word64Rep r a i + +-- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr. + +translateOp [r] ReadOffAddrOp_Char [a,i] = doIndexOffAddrOp Word8Rep r a i +translateOp [r] ReadOffAddrOp_WideChar [a,i] = doIndexOffAddrOp Word32Rep r a i +translateOp [r] ReadOffAddrOp_Int [a,i] = doIndexOffAddrOp IntRep r a i +translateOp [r] ReadOffAddrOp_Word [a,i] = doIndexOffAddrOp WordRep r a i +translateOp [r] ReadOffAddrOp_Addr [a,i] = doIndexOffAddrOp AddrRep r a i +translateOp [r] ReadOffAddrOp_Float [a,i] = doIndexOffAddrOp FloatRep r a i +translateOp [r] ReadOffAddrOp_Double [a,i] = doIndexOffAddrOp DoubleRep r a i +translateOp [r] ReadOffAddrOp_StablePtr [a,i] = doIndexOffAddrOp StablePtrRep r a i + +translateOp [r] ReadOffAddrOp_Int8 [a,i] = doIndexOffAddrOp Int8Rep r a i +translateOp [r] ReadOffAddrOp_Int16 [a,i] = doIndexOffAddrOp Int16Rep r a i +translateOp [r] ReadOffAddrOp_Int32 [a,i] = doIndexOffAddrOp Int32Rep r a i +translateOp [r] ReadOffAddrOp_Int64 [a,i] = doIndexOffAddrOp Int64Rep r a i + +translateOp [r] ReadOffAddrOp_Word8 [a,i] = doIndexOffAddrOp Word8Rep r a i +translateOp [r] ReadOffAddrOp_Word16 [a,i] = doIndexOffAddrOp Word16Rep r a i +translateOp [r] ReadOffAddrOp_Word32 [a,i] = doIndexOffAddrOp Word32Rep r a i +translateOp [r] ReadOffAddrOp_Word64 [a,i] = doIndexOffAddrOp Word64Rep r a i + +-- WriteXXXoffAddr + +translateOp [] WriteOffAddrOp_Char [a,i,x] = doWriteOffAddrOp Word8Rep a i x +translateOp [] WriteOffAddrOp_WideChar [a,i,x] = doWriteOffAddrOp Word32Rep a i x +translateOp [] WriteOffAddrOp_Int [a,i,x] = doWriteOffAddrOp IntRep a i x +translateOp [] WriteOffAddrOp_Word [a,i,x] = doWriteOffAddrOp WordRep a i x +translateOp [] WriteOffAddrOp_Addr [a,i,x] = doWriteOffAddrOp AddrRep a i x +translateOp [] WriteOffAddrOp_Float [a,i,x] = doWriteOffAddrOp FloatRep a i x +translateOp [] WriteOffAddrOp_ForeignObj [a,i,x] = doWriteOffAddrOp ForeignObjRep a i x +translateOp [] WriteOffAddrOp_Double [a,i,x] = doWriteOffAddrOp DoubleRep a i x +translateOp [] WriteOffAddrOp_StablePtr [a,i,x] = doWriteOffAddrOp StablePtrRep a i x + +translateOp [] WriteOffAddrOp_Int8 [a,i,x] = doWriteOffAddrOp Int8Rep a i x +translateOp [] WriteOffAddrOp_Int16 [a,i,x] = doWriteOffAddrOp Int16Rep a i x +translateOp [] WriteOffAddrOp_Int32 [a,i,x] = doWriteOffAddrOp Int32Rep a i x +translateOp [] WriteOffAddrOp_Int64 [a,i,x] = doWriteOffAddrOp Int64Rep a i x + +translateOp [] WriteOffAddrOp_Word8 [a,i,x] = doWriteOffAddrOp Word8Rep a i x +translateOp [] WriteOffAddrOp_Word16 [a,i,x] = doWriteOffAddrOp Word16Rep a i x +translateOp [] WriteOffAddrOp_Word32 [a,i,x] = doWriteOffAddrOp Word32Rep a i x +translateOp [] WriteOffAddrOp_Word64 [a,i,x] = doWriteOffAddrOp Word64Rep a i x + +-- IndexXXXArray + +translateOp [r] IndexByteArrayOp_Char [a,i] = doIndexByteArrayOp Word8Rep r a i +translateOp [r] IndexByteArrayOp_WideChar [a,i] = doIndexByteArrayOp Word32Rep r a i +translateOp [r] IndexByteArrayOp_Int [a,i] = doIndexByteArrayOp IntRep r a i +translateOp [r] IndexByteArrayOp_Word [a,i] = doIndexByteArrayOp WordRep r a i +translateOp [r] IndexByteArrayOp_Addr [a,i] = doIndexByteArrayOp AddrRep r a i +translateOp [r] IndexByteArrayOp_Float [a,i] = doIndexByteArrayOp FloatRep r a i +translateOp [r] IndexByteArrayOp_Double [a,i] = doIndexByteArrayOp DoubleRep r a i +translateOp [r] IndexByteArrayOp_StablePtr [a,i] = doIndexByteArrayOp StablePtrRep r a i + +translateOp [r] IndexByteArrayOp_Int8 [a,i] = doIndexByteArrayOp Int8Rep r a i +translateOp [r] IndexByteArrayOp_Int16 [a,i] = doIndexByteArrayOp Int16Rep r a i +translateOp [r] IndexByteArrayOp_Int32 [a,i] = doIndexByteArrayOp Int32Rep r a i +translateOp [r] IndexByteArrayOp_Int64 [a,i] = doIndexByteArrayOp Int64Rep r a i + +translateOp [r] IndexByteArrayOp_Word8 [a,i] = doIndexByteArrayOp Word8Rep r a i +translateOp [r] IndexByteArrayOp_Word16 [a,i] = doIndexByteArrayOp Word16Rep r a i +translateOp [r] IndexByteArrayOp_Word32 [a,i] = doIndexByteArrayOp Word32Rep r a i +translateOp [r] IndexByteArrayOp_Word64 [a,i] = doIndexByteArrayOp Word64Rep r a i + +-- ReadXXXArray, identical to IndexXXXArray. + +translateOp [r] ReadByteArrayOp_Char [a,i] = doIndexByteArrayOp Word8Rep r a i +translateOp [r] ReadByteArrayOp_WideChar [a,i] = doIndexByteArrayOp Word32Rep r a i +translateOp [r] ReadByteArrayOp_Int [a,i] = doIndexByteArrayOp IntRep r a i +translateOp [r] ReadByteArrayOp_Word [a,i] = doIndexByteArrayOp WordRep r a i +translateOp [r] ReadByteArrayOp_Addr [a,i] = doIndexByteArrayOp AddrRep r a i +translateOp [r] ReadByteArrayOp_Float [a,i] = doIndexByteArrayOp FloatRep r a i +translateOp [r] ReadByteArrayOp_Double [a,i] = doIndexByteArrayOp DoubleRep r a i +translateOp [r] ReadByteArrayOp_StablePtr [a,i] = doIndexByteArrayOp StablePtrRep r a i + +translateOp [r] ReadByteArrayOp_Int8 [a,i] = doIndexByteArrayOp Int8Rep r a i +translateOp [r] ReadByteArrayOp_Int16 [a,i] = doIndexByteArrayOp Int16Rep r a i +translateOp [r] ReadByteArrayOp_Int32 [a,i] = doIndexByteArrayOp Int32Rep r a i +translateOp [r] ReadByteArrayOp_Int64 [a,i] = doIndexByteArrayOp Int64Rep r a i + +translateOp [r] ReadByteArrayOp_Word8 [a,i] = doIndexByteArrayOp Word8Rep r a i +translateOp [r] ReadByteArrayOp_Word16 [a,i] = doIndexByteArrayOp Word16Rep r a i +translateOp [r] ReadByteArrayOp_Word32 [a,i] = doIndexByteArrayOp Word32Rep r a i +translateOp [r] ReadByteArrayOp_Word64 [a,i] = doIndexByteArrayOp Word64Rep r a i + +-- WriteXXXArray + +translateOp [] WriteByteArrayOp_Char [a,i,x] = doWriteByteArrayOp Word8Rep a i x +translateOp [] WriteByteArrayOp_WideChar [a,i,x] = doWriteByteArrayOp Word32Rep a i x +translateOp [] WriteByteArrayOp_Int [a,i,x] = doWriteByteArrayOp IntRep a i x +translateOp [] WriteByteArrayOp_Word [a,i,x] = doWriteByteArrayOp WordRep a i x +translateOp [] WriteByteArrayOp_Addr [a,i,x] = doWriteByteArrayOp AddrRep a i x +translateOp [] WriteByteArrayOp_Float [a,i,x] = doWriteByteArrayOp FloatRep a i x +translateOp [] WriteByteArrayOp_Double [a,i,x] = doWriteByteArrayOp DoubleRep a i x +translateOp [] WriteByteArrayOp_StablePtr [a,i,x] = doWriteByteArrayOp StablePtrRep a i x + +translateOp [] WriteByteArrayOp_Int8 [a,i,x] = doWriteByteArrayOp Int8Rep a i x +translateOp [] WriteByteArrayOp_Int16 [a,i,x] = doWriteByteArrayOp Int16Rep a i x +translateOp [] WriteByteArrayOp_Int32 [a,i,x] = doWriteByteArrayOp Int32Rep a i x +translateOp [] WriteByteArrayOp_Int64 [a,i,x] = doWriteByteArrayOp Int64Rep a i x + +translateOp [] WriteByteArrayOp_Word8 [a,i,x] = doWriteByteArrayOp Word8Rep a i x +translateOp [] WriteByteArrayOp_Word16 [a,i,x] = doWriteByteArrayOp Word16Rep a i x +translateOp [] WriteByteArrayOp_Word32 [a,i,x] = doWriteByteArrayOp Word32Rep a i x +translateOp [] WriteByteArrayOp_Word64 [a,i,x] = doWriteByteArrayOp Word64Rep a i x + +-- Native word signless ops + +translateOp [r] IntAddOp [a1,a2] = Just (Just1 r, MO_Nat_Add, [a1,a2]) +translateOp [r] IntSubOp [a1,a2] = Just (Just1 r, MO_Nat_Sub, [a1,a2]) +translateOp [r] WordAddOp [a1,a2] = Just (Just1 r, MO_Nat_Add, [a1,a2]) +translateOp [r] WordSubOp [a1,a2] = Just (Just1 r, MO_Nat_Sub, [a1,a2]) +translateOp [r] AddrAddOp [a1,a2] = Just (Just1 r, MO_Nat_Add, [a1,a2]) +translateOp [r] AddrSubOp [a1,a2] = Just (Just1 r, MO_Nat_Sub, [a1,a2]) + +translateOp [r] IntEqOp [a1,a2] = Just (Just1 r, MO_Nat_Eq, [a1,a2]) +translateOp [r] IntNeOp [a1,a2] = Just (Just1 r, MO_Nat_Ne, [a1,a2]) +translateOp [r] WordEqOp [a1,a2] = Just (Just1 r, MO_Nat_Eq, [a1,a2]) +translateOp [r] WordNeOp [a1,a2] = Just (Just1 r, MO_Nat_Ne, [a1,a2]) +translateOp [r] AddrEqOp [a1,a2] = Just (Just1 r, MO_Nat_Eq, [a1,a2]) +translateOp [r] AddrNeOp [a1,a2] = Just (Just1 r, MO_Nat_Ne, [a1,a2]) + +translateOp [r] AndOp [a1,a2] = Just (Just1 r, MO_Nat_And, [a1,a2]) +translateOp [r] OrOp [a1,a2] = Just (Just1 r, MO_Nat_Or, [a1,a2]) +translateOp [r] XorOp [a1,a2] = Just (Just1 r, MO_Nat_Xor, [a1,a2]) +translateOp [r] NotOp [a1] = Just (Just1 r, MO_Nat_Not, [a1]) + +-- Native word signed ops + +translateOp [r] IntMulOp [a1,a2] = Just (Just1 r, MO_NatS_Mul, [a1,a2]) +translateOp [r] IntQuotOp [a1,a2] = Just (Just1 r, MO_NatS_Quot, [a1,a2]) +translateOp [r] IntRemOp [a1,a2] = Just (Just1 r, MO_NatS_Rem, [a1,a2]) +translateOp [r] IntNegOp [a1] = Just (Just1 r, MO_NatS_Neg, [a1]) + +translateOp [r,c] IntAddCOp [a1,a2] = Just (Just2 r c, MO_NatS_AddC, [a1,a2]) +translateOp [r,c] IntSubCOp [a1,a2] = Just (Just2 r c, MO_NatS_SubC, [a1,a2]) +translateOp [r,c] IntMulCOp [a1,a2] = Just (Just2 r c, MO_NatS_MulC, [a1,a2]) + +translateOp [r] IntGeOp [a1,a2] = Just (Just1 r, MO_NatS_Ge, [a1,a2]) +translateOp [r] IntLeOp [a1,a2] = Just (Just1 r, MO_NatS_Le, [a1,a2]) +translateOp [r] IntGtOp [a1,a2] = Just (Just1 r, MO_NatS_Gt, [a1,a2]) +translateOp [r] IntLtOp [a1,a2] = Just (Just1 r, MO_NatS_Lt, [a1,a2]) + +-- Native word unsigned ops + +translateOp [r] WordGeOp [a1,a2] = Just (Just1 r, MO_NatU_Ge, [a1,a2]) +translateOp [r] WordLeOp [a1,a2] = Just (Just1 r, MO_NatU_Le, [a1,a2]) +translateOp [r] WordGtOp [a1,a2] = Just (Just1 r, MO_NatU_Gt, [a1,a2]) +translateOp [r] WordLtOp [a1,a2] = Just (Just1 r, MO_NatU_Lt, [a1,a2]) + +translateOp [r] WordMulOp [a1,a2] = Just (Just1 r, MO_NatU_Mul, [a1,a2]) +translateOp [r] WordQuotOp [a1,a2] = Just (Just1 r, MO_NatU_Quot, [a1,a2]) +translateOp [r] WordRemOp [a1,a2] = Just (Just1 r, MO_NatU_Rem, [a1,a2]) + +translateOp [r] AddrGeOp [a1,a2] = Just (Just1 r, MO_NatU_Ge, [a1,a2]) +translateOp [r] AddrLeOp [a1,a2] = Just (Just1 r, MO_NatU_Le, [a1,a2]) +translateOp [r] AddrGtOp [a1,a2] = Just (Just1 r, MO_NatU_Gt, [a1,a2]) +translateOp [r] AddrLtOp [a1,a2] = Just (Just1 r, MO_NatU_Lt, [a1,a2]) + +-- 32-bit unsigned ops + +translateOp [r] CharEqOp [a1,a2] = Just (Just1 r, MO_32U_Eq, [a1,a2]) +translateOp [r] CharNeOp [a1,a2] = Just (Just1 r, MO_32U_Ne, [a1,a2]) +translateOp [r] CharGeOp [a1,a2] = Just (Just1 r, MO_32U_Ge, [a1,a2]) +translateOp [r] CharLeOp [a1,a2] = Just (Just1 r, MO_32U_Le, [a1,a2]) +translateOp [r] CharGtOp [a1,a2] = Just (Just1 r, MO_32U_Gt, [a1,a2]) +translateOp [r] CharLtOp [a1,a2] = Just (Just1 r, MO_32U_Lt, [a1,a2]) + +-- Double ops + +translateOp [r] DoubleEqOp [a1,a2] = Just (Just1 r, MO_Dbl_Eq, [a1,a2]) +translateOp [r] DoubleNeOp [a1,a2] = Just (Just1 r, MO_Dbl_Ne, [a1,a2]) +translateOp [r] DoubleGeOp [a1,a2] = Just (Just1 r, MO_Dbl_Ge, [a1,a2]) +translateOp [r] DoubleLeOp [a1,a2] = Just (Just1 r, MO_Dbl_Le, [a1,a2]) +translateOp [r] DoubleGtOp [a1,a2] = Just (Just1 r, MO_Dbl_Gt, [a1,a2]) +translateOp [r] DoubleLtOp [a1,a2] = Just (Just1 r, MO_Dbl_Lt, [a1,a2]) + +translateOp [r] DoubleAddOp [a1,a2] = Just (Just1 r, MO_Dbl_Add, [a1,a2]) +translateOp [r] DoubleSubOp [a1,a2] = Just (Just1 r, MO_Dbl_Sub, [a1,a2]) +translateOp [r] DoubleMulOp [a1,a2] = Just (Just1 r, MO_Dbl_Mul, [a1,a2]) +translateOp [r] DoubleDivOp [a1,a2] = Just (Just1 r, MO_Dbl_Div, [a1,a2]) +translateOp [r] DoublePowerOp [a1,a2] = Just (Just1 r, MO_Dbl_Pwr, [a1,a2]) + +translateOp [r] DoubleSinOp [a1] = Just (Just1 r, MO_Dbl_Sin, [a1]) +translateOp [r] DoubleCosOp [a1] = Just (Just1 r, MO_Dbl_Cos, [a1]) +translateOp [r] DoubleTanOp [a1] = Just (Just1 r, MO_Dbl_Tan, [a1]) +translateOp [r] DoubleSinhOp [a1] = Just (Just1 r, MO_Dbl_Sinh, [a1]) +translateOp [r] DoubleCoshOp [a1] = Just (Just1 r, MO_Dbl_Cosh, [a1]) +translateOp [r] DoubleTanhOp [a1] = Just (Just1 r, MO_Dbl_Tanh, [a1]) +translateOp [r] DoubleAsinOp [a1] = Just (Just1 r, MO_Dbl_Asin, [a1]) +translateOp [r] DoubleAcosOp [a1] = Just (Just1 r, MO_Dbl_Acos, [a1]) +translateOp [r] DoubleAtanOp [a1] = Just (Just1 r, MO_Dbl_Atan, [a1]) +translateOp [r] DoubleLogOp [a1] = Just (Just1 r, MO_Dbl_Log, [a1]) +translateOp [r] DoubleExpOp [a1] = Just (Just1 r, MO_Dbl_Exp, [a1]) +translateOp [r] DoubleSqrtOp [a1] = Just (Just1 r, MO_Dbl_Sqrt, [a1]) +translateOp [r] DoubleNegOp [a1] = Just (Just1 r, MO_Dbl_Neg, [a1]) + +-- Float ops + +translateOp [r] FloatEqOp [a1,a2] = Just (Just1 r, MO_Flt_Eq, [a1,a2]) +translateOp [r] FloatNeOp [a1,a2] = Just (Just1 r, MO_Flt_Ne, [a1,a2]) +translateOp [r] FloatGeOp [a1,a2] = Just (Just1 r, MO_Flt_Ge, [a1,a2]) +translateOp [r] FloatLeOp [a1,a2] = Just (Just1 r, MO_Flt_Le, [a1,a2]) +translateOp [r] FloatGtOp [a1,a2] = Just (Just1 r, MO_Flt_Gt, [a1,a2]) +translateOp [r] FloatLtOp [a1,a2] = Just (Just1 r, MO_Flt_Lt, [a1,a2]) + +translateOp [r] FloatAddOp [a1,a2] = Just (Just1 r, MO_Flt_Add, [a1,a2]) +translateOp [r] FloatSubOp [a1,a2] = Just (Just1 r, MO_Flt_Sub, [a1,a2]) +translateOp [r] FloatMulOp [a1,a2] = Just (Just1 r, MO_Flt_Mul, [a1,a2]) +translateOp [r] FloatDivOp [a1,a2] = Just (Just1 r, MO_Flt_Div, [a1,a2]) +translateOp [r] FloatPowerOp [a1,a2] = Just (Just1 r, MO_Flt_Pwr, [a1,a2]) + +translateOp [r] FloatSinOp [a1] = Just (Just1 r, MO_Flt_Sin, [a1]) +translateOp [r] FloatCosOp [a1] = Just (Just1 r, MO_Flt_Cos, [a1]) +translateOp [r] FloatTanOp [a1] = Just (Just1 r, MO_Flt_Tan, [a1]) +translateOp [r] FloatSinhOp [a1] = Just (Just1 r, MO_Flt_Sinh, [a1]) +translateOp [r] FloatCoshOp [a1] = Just (Just1 r, MO_Flt_Cosh, [a1]) +translateOp [r] FloatTanhOp [a1] = Just (Just1 r, MO_Flt_Tanh, [a1]) +translateOp [r] FloatAsinOp [a1] = Just (Just1 r, MO_Flt_Asin, [a1]) +translateOp [r] FloatAcosOp [a1] = Just (Just1 r, MO_Flt_Acos, [a1]) +translateOp [r] FloatAtanOp [a1] = Just (Just1 r, MO_Flt_Atan, [a1]) +translateOp [r] FloatLogOp [a1] = Just (Just1 r, MO_Flt_Log, [a1]) +translateOp [r] FloatExpOp [a1] = Just (Just1 r, MO_Flt_Exp, [a1]) +translateOp [r] FloatSqrtOp [a1] = Just (Just1 r, MO_Flt_Sqrt, [a1]) +translateOp [r] FloatNegOp [a1] = Just (Just1 r, MO_Flt_Neg, [a1]) + +-- Conversions + +translateOp [r] Int2DoubleOp [a1] = Just (Just1 r, MO_NatS_to_Dbl, [a1]) +translateOp [r] Double2IntOp [a1] = Just (Just1 r, MO_Dbl_to_NatS, [a1]) + +translateOp [r] Int2FloatOp [a1] = Just (Just1 r, MO_NatS_to_Flt, [a1]) +translateOp [r] Float2IntOp [a1] = Just (Just1 r, MO_Flt_to_NatS, [a1]) + +translateOp [r] Float2DoubleOp [a1] = Just (Just1 r, MO_Flt_to_Dbl, [a1]) +translateOp [r] Double2FloatOp [a1] = Just (Just1 r, MO_Dbl_to_Flt, [a1]) + +translateOp [r] Int2WordOp [a1] = Just (Just1 r, MO_NatS_to_NatU, [a1]) +translateOp [r] Word2IntOp [a1] = Just (Just1 r, MO_NatU_to_NatS, [a1]) + +translateOp [r] Int2AddrOp [a1] = Just (Just1 r, MO_NatS_to_NatP, [a1]) +translateOp [r] Addr2IntOp [a1] = Just (Just1 r, MO_NatP_to_NatS, [a1]) + +translateOp [r] OrdOp [a1] = Just (Just1 r, MO_32U_to_NatS, [a1]) +translateOp [r] ChrOp [a1] = Just (Just1 r, MO_NatS_to_32U, [a1]) + +translateOp [r] Narrow8IntOp [a1] = Just (Just1 r, MO_8S_to_NatS, [a1]) +translateOp [r] Narrow16IntOp [a1] = Just (Just1 r, MO_16S_to_NatS, [a1]) +translateOp [r] Narrow32IntOp [a1] = Just (Just1 r, MO_32S_to_NatS, [a1]) + +translateOp [r] Narrow8WordOp [a1] = Just (Just1 r, MO_8U_to_NatU, [a1]) +translateOp [r] Narrow16WordOp [a1] = Just (Just1 r, MO_16U_to_NatU, [a1]) +translateOp [r] Narrow32WordOp [a1] = Just (Just1 r, MO_32U_to_NatU, [a1]) + +translateOp [r] SameMutVarOp [a1,a2] = Just (Just1 r, MO_Nat_Eq, [a1,a2]) +translateOp [r] SameMVarOp [a1,a2] = Just (Just1 r, MO_Nat_Eq, [a1,a2]) +translateOp [r] SameMutableArrayOp [a1,a2] = Just (Just1 r, MO_Nat_Eq, [a1,a2]) +translateOp [r] SameMutableByteArrayOp [a1,a2] = Just (Just1 r, MO_Nat_Eq, [a1,a2]) +translateOp [r] EqForeignObj [a1,a2] = Just (Just1 r, MO_Nat_Eq, [a1,a2]) +translateOp [r] EqStablePtrOp [a1,a2] = Just (Just1 r, MO_Nat_Eq, [a1,a2]) + +translateOp _ _ _ = Nothing + +\end{code} diff --git a/ghc/compiler/absCSyn/CLabel.lhs b/ghc/compiler/absCSyn/CLabel.lhs index 4da5c5773a..ae46087838 100644 --- a/ghc/compiler/absCSyn/CLabel.lhs +++ b/ghc/compiler/absCSyn/CLabel.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CLabel.lhs,v 1.48 2001/11/08 12:56:01 simonmar Exp $ +% $Id: CLabel.lhs,v 1.49 2001/12/05 17:35:12 sewardj Exp $ % \section[CLabel]{@CLabel@: Information to make C Labels} @@ -348,6 +348,7 @@ labelType (RtsLabel (RtsBlackHoleInfoTbl _)) = InfoTblType labelType (RtsLabel (RtsSelectorInfoTbl _ _)) = InfoTblType labelType (RtsLabel (RtsApInfoTbl _ _)) = InfoTblType labelType (RtsLabel RtsUpdInfo) = InfoTblType +labelType (RtsLabel (Rts_Info _)) = InfoTblType labelType (CaseLabel _ CaseReturnInfo) = InfoTblType labelType (CaseLabel _ CaseReturnPt) = CodeType labelType (CaseLabel _ CaseVecTbl) = VecTblType diff --git a/ghc/compiler/absCSyn/MachOp.hs b/ghc/compiler/absCSyn/MachOp.hs new file mode 100644 index 0000000000..e17cde4389 --- /dev/null +++ b/ghc/compiler/absCSyn/MachOp.hs @@ -0,0 +1,478 @@ + +module MachOp ( MachOp(..), pprMachOp, + isDefinitelyInlineMachOp, + isCommutableMachOp, + isComparisonMachOp, + resultRepsOfMachOp + ) +where + +#include "HsVersions.h" + +import PrimRep ( PrimRep(..) ) +import Maybes ( Maybe012(..) ) +import Outputable + + +{- Machine-level primops; ones which we can reasonably delegate to the + native code generators to handle. Basically contains C's primops + and no others. + + Nomenclature: all ops indicate width and signedness, where + appropriate. Widths: 8/16/32/64 means the given size, obviously. + Nat means the native word size. Signedness: S means signed, U + means unsigned. For operations where signedness is irrelevant or + makes no difference (for example integer add), the signedness + component is omitted. + + An exception: NatP is a ptr-typed native word. From the point of + view of the native code generators this distinction is irrelevant, + but the C code generator sometimes needs this info to emit the + right casts. +-} + +data MachOp + + -- OPS at the native word size + = MO_Nat_Add -- + + | MO_Nat_Sub -- - + | MO_Nat_Eq + | MO_Nat_Ne + + | MO_NatS_Ge + | MO_NatS_Le + | MO_NatS_Gt + | MO_NatS_Lt + + | MO_NatU_Ge + | MO_NatU_Le + | MO_NatU_Gt + | MO_NatU_Lt + + | MO_NatS_Mul -- signed * + | MO_NatS_Quot -- signed / (same semantics as IntQuotOp) + | MO_NatS_Rem -- signed % (same semantics as IntRemOp) + | MO_NatS_Neg -- unary - + + | MO_NatU_Mul -- unsigned * + | MO_NatU_Quot -- unsigned / (same semantics as WordQuotOp) + | MO_NatU_Rem -- unsigned % (same semantics as WordRemOp) + + | MO_NatS_AddC -- signed +, first result sum, second result carry + | MO_NatS_SubC -- signed -, first result sum, second result borrow + | MO_NatS_MulC -- signed *, first result sum, second result carry + + | MO_Nat_And + | MO_Nat_Or + | MO_Nat_Xor + | MO_Nat_Not + | MO_Nat_Shl + | MO_Nat_Shr + | MO_Nat_Sar + + -- OPS at 32 bits regardless of word size + | MO_32U_Eq + | MO_32U_Ne + | MO_32U_Ge + | MO_32U_Le + | MO_32U_Gt + | MO_32U_Lt + + -- IEEE754 Double ops + | MO_Dbl_Eq + | MO_Dbl_Ne + | MO_Dbl_Ge + | MO_Dbl_Le + | MO_Dbl_Gt + | MO_Dbl_Lt + + | MO_Dbl_Add + | MO_Dbl_Sub + | MO_Dbl_Mul + | MO_Dbl_Div + | MO_Dbl_Pwr + + | MO_Dbl_Sin + | MO_Dbl_Cos + | MO_Dbl_Tan + | MO_Dbl_Sinh + | MO_Dbl_Cosh + | MO_Dbl_Tanh + | MO_Dbl_Asin + | MO_Dbl_Acos + | MO_Dbl_Atan + | MO_Dbl_Log + | MO_Dbl_Exp + | MO_Dbl_Sqrt + | MO_Dbl_Neg + + -- IEEE754 Float ops + | MO_Flt_Add + | MO_Flt_Sub + | MO_Flt_Mul + | MO_Flt_Div + | MO_Flt_Pwr + + | MO_Flt_Eq + | MO_Flt_Ne + | MO_Flt_Ge + | MO_Flt_Le + | MO_Flt_Gt + | MO_Flt_Lt + + | MO_Flt_Sin + | MO_Flt_Cos + | MO_Flt_Tan + | MO_Flt_Sinh + | MO_Flt_Cosh + | MO_Flt_Tanh + | MO_Flt_Asin + | MO_Flt_Acos + | MO_Flt_Atan + | MO_Flt_Log + | MO_Flt_Exp + | MO_Flt_Neg + | MO_Flt_Sqrt + + -- Conversions. Some of these are NOPs, in which case they + -- are here usually to placate the C code generator. + | MO_32U_to_NatS + | MO_NatS_to_32U + + | MO_NatS_to_Dbl + | MO_Dbl_to_NatS + + | MO_NatS_to_Flt + | MO_Flt_to_NatS + + | MO_NatS_to_NatU + | MO_NatU_to_NatS + + | MO_NatS_to_NatP + | MO_NatP_to_NatS + | MO_NatU_to_NatP + | MO_NatP_to_NatU + + | MO_Dbl_to_Flt + | MO_Flt_to_Dbl + + | MO_8S_to_NatS + | MO_16S_to_NatS + | MO_32S_to_NatS + | MO_8U_to_NatU + | MO_16U_to_NatU + | MO_32U_to_NatU + + -- Reading/writing arrays + | MO_ReadOSBI Int PrimRep -- [base_ptr, index_value] + | MO_WriteOSBI Int PrimRep -- [base_ptr, index_value, value_to_write] + -- Read/write a value :: the PrimRep + -- at byte address + -- sizeof(machine_word)*Int + base_ptr + sizeof(PrimRep)*index_value + deriving Eq + + + +-- Almost, but not quite == text . derived show +pprMachOp :: MachOp -> SDoc + +pprMachOp MO_Nat_Add = text "MO_Nat_Add" +pprMachOp MO_Nat_Sub = text "MO_Nat_Sub" +pprMachOp MO_Nat_Eq = text "MO_Nat_Eq" +pprMachOp MO_Nat_Ne = text "MO_Nat_Ne" + +pprMachOp MO_NatS_Ge = text "MO_NatS_Ge" +pprMachOp MO_NatS_Le = text "MO_NatS_Le" +pprMachOp MO_NatS_Gt = text "MO_NatS_Gt" +pprMachOp MO_NatS_Lt = text "MO_NatS_Lt" + +pprMachOp MO_NatU_Ge = text "MO_NatU_Ge" +pprMachOp MO_NatU_Le = text "MO_NatU_Le" +pprMachOp MO_NatU_Gt = text "MO_NatU_Gt" +pprMachOp MO_NatU_Lt = text "MO_NatU_Lt" + +pprMachOp MO_NatS_Mul = text "MO_NatS_Mul" +pprMachOp MO_NatS_Quot = text "MO_NatS_Quot" +pprMachOp MO_NatS_Rem = text "MO_NatS_Rem" +pprMachOp MO_NatS_Neg = text "MO_NatS_Neg" + +pprMachOp MO_NatU_Mul = text "MO_NatU_Mul" +pprMachOp MO_NatU_Quot = text "MO_NatU_Quot" +pprMachOp MO_NatU_Rem = text "MO_NatU_Rem" + +pprMachOp MO_NatS_AddC = text "MO_NatS_AddC" +pprMachOp MO_NatS_SubC = text "MO_NatS_SubC" +pprMachOp MO_NatS_MulC = text "MO_NatS_MulC" + +pprMachOp MO_Nat_And = text "MO_Nat_And" +pprMachOp MO_Nat_Or = text "MO_Nat_Or" +pprMachOp MO_Nat_Xor = text "MO_Nat_Xor" +pprMachOp MO_Nat_Not = text "MO_Nat_Not" +pprMachOp MO_Nat_Shl = text "MO_Nat_Shl" +pprMachOp MO_Nat_Shr = text "MO_Nat_Shr" +pprMachOp MO_Nat_Sar = text "MO_Nat_Sar" + +pprMachOp MO_32U_Eq = text "MO_32U_Eq" +pprMachOp MO_32U_Ne = text "MO_32U_Ne" +pprMachOp MO_32U_Ge = text "MO_32U_Ge" +pprMachOp MO_32U_Le = text "MO_32U_Le" +pprMachOp MO_32U_Gt = text "MO_32U_Gt" +pprMachOp MO_32U_Lt = text "MO_32U_Lt" + +pprMachOp MO_Dbl_Eq = text "MO_Dbl_Eq" +pprMachOp MO_Dbl_Ne = text "MO_Dbl_Ne" +pprMachOp MO_Dbl_Ge = text "MO_Dbl_Ge" +pprMachOp MO_Dbl_Le = text "MO_Dbl_Le" +pprMachOp MO_Dbl_Gt = text "MO_Dbl_Gt" +pprMachOp MO_Dbl_Lt = text "MO_Dbl_Lt" + +pprMachOp MO_Dbl_Add = text "MO_Dbl_Add" +pprMachOp MO_Dbl_Sub = text "MO_Dbl_Sub" +pprMachOp MO_Dbl_Mul = text "MO_Dbl_Mul" +pprMachOp MO_Dbl_Div = text "MO_Dbl_Div" +pprMachOp MO_Dbl_Pwr = text "MO_Dbl_Pwr" + +pprMachOp MO_Dbl_Sin = text "MO_Dbl_Sin" +pprMachOp MO_Dbl_Cos = text "MO_Dbl_Cos" +pprMachOp MO_Dbl_Tan = text "MO_Dbl_Tan" +pprMachOp MO_Dbl_Sinh = text "MO_Dbl_Sinh" +pprMachOp MO_Dbl_Cosh = text "MO_Dbl_Cosh" +pprMachOp MO_Dbl_Tanh = text "MO_Dbl_Tanh" +pprMachOp MO_Dbl_Asin = text "MO_Dbl_Asin" +pprMachOp MO_Dbl_Acos = text "MO_Dbl_Acos" +pprMachOp MO_Dbl_Atan = text "MO_Dbl_Atan" +pprMachOp MO_Dbl_Log = text "MO_Dbl_Log" +pprMachOp MO_Dbl_Exp = text "MO_Dbl_Exp" +pprMachOp MO_Dbl_Sqrt = text "MO_Dbl_Sqrt" +pprMachOp MO_Dbl_Neg = text "MO_Dbl_Neg" + +pprMachOp MO_Flt_Add = text "MO_Flt_Add" +pprMachOp MO_Flt_Sub = text "MO_Flt_Sub" +pprMachOp MO_Flt_Mul = text "MO_Flt_Mul" +pprMachOp MO_Flt_Div = text "MO_Flt_Div" +pprMachOp MO_Flt_Pwr = text "MO_Flt_Pwr" + +pprMachOp MO_Flt_Eq = text "MO_Flt_Eq" +pprMachOp MO_Flt_Ne = text "MO_Flt_Ne" +pprMachOp MO_Flt_Ge = text "MO_Flt_Ge" +pprMachOp MO_Flt_Le = text "MO_Flt_Le" +pprMachOp MO_Flt_Gt = text "MO_Flt_Gt" +pprMachOp MO_Flt_Lt = text "MO_Flt_Lt" + +pprMachOp MO_Flt_Sin = text "MO_Flt_Sin" +pprMachOp MO_Flt_Cos = text "MO_Flt_Cos" +pprMachOp MO_Flt_Tan = text "MO_Flt_Tan" +pprMachOp MO_Flt_Sinh = text "MO_Flt_Sinh" +pprMachOp MO_Flt_Cosh = text "MO_Flt_Cosh" +pprMachOp MO_Flt_Tanh = text "MO_Flt_Tanh" +pprMachOp MO_Flt_Asin = text "MO_Flt_Asin" +pprMachOp MO_Flt_Acos = text "MO_Flt_Acos" +pprMachOp MO_Flt_Atan = text "MO_Flt_Atan" +pprMachOp MO_Flt_Log = text "MO_Flt_Log" +pprMachOp MO_Flt_Exp = text "MO_Flt_Exp" +pprMachOp MO_Flt_Sqrt = text "MO_Flt_Sqrt" +pprMachOp MO_Flt_Neg = text "MO_Flt_Neg" + +pprMachOp MO_32U_to_NatS = text "MO_32U_to_NatS" +pprMachOp MO_NatS_to_32U = text "MO_NatS_to_32U" + +pprMachOp MO_NatS_to_Dbl = text "MO_NatS_to_Dbl" +pprMachOp MO_Dbl_to_NatS = text "MO_Dbl_to_NatS" + +pprMachOp MO_NatS_to_Flt = text "MO_NatS_to_Flt" +pprMachOp MO_Flt_to_NatS = text "MO_Flt_to_NatS" + +pprMachOp MO_NatS_to_NatU = text "MO_NatS_to_NatU" +pprMachOp MO_NatU_to_NatS = text "MO_NatU_to_NatS" + +pprMachOp MO_NatS_to_NatP = text "MO_NatS_to_NatP" +pprMachOp MO_NatP_to_NatS = text "MO_NatP_to_NatS" +pprMachOp MO_NatU_to_NatP = text "MO_NatU_to_NatP" +pprMachOp MO_NatP_to_NatU = text "MO_NatP_to_NatU" + +pprMachOp MO_Dbl_to_Flt = text "MO_Dbl_to_Flt" +pprMachOp MO_Flt_to_Dbl = text "MO_Flt_to_Dbl" + +pprMachOp MO_8S_to_NatS = text "MO_8S_to_NatS" +pprMachOp MO_16S_to_NatS = text "MO_16S_to_NatS" +pprMachOp MO_32S_to_NatS = text "MO_32S_to_NatS" + +pprMachOp MO_8U_to_NatU = text "MO_8U_to_NatU" +pprMachOp MO_16U_to_NatU = text "MO_16U_to_NatU" +pprMachOp MO_32U_to_NatU = text "MO_32U_to_NatU" + +pprMachOp (MO_ReadOSBI offset rep) + = text "MO_ReadOSBI" <> parens (int offset <> comma <> ppr rep) +pprMachOp (MO_WriteOSBI offset rep) + = text "MO_WriteOSBI" <> parens (int offset <> comma <> ppr rep) + + + +-- Non-exported helper enumeration: +data MO_Prop + = MO_Commutable + | MO_DefinitelyInline + | MO_Comparison + deriving Eq + +comm = MO_Commutable +inline = MO_DefinitelyInline +comp = MO_Comparison + + +-- If in doubt, return False. This generates worse code on the +-- via-C route, but has no effect on the native code routes. +-- Remember that claims about definitely inline have to be true +-- regardless of what the C compiler does, so we need to be +-- careful about boundary cases like sqrt which are sometimes +-- implemented in software and sometimes in hardware. +isDefinitelyInlineMachOp :: MachOp -> Bool +isDefinitelyInlineMachOp mop = inline `elem` snd (machOpProps mop) + +-- If in doubt, return False. This generates worse code on the +-- native routes, but is otherwise harmless. +isCommutableMachOp :: MachOp -> Bool +isCommutableMachOp mop = comm `elem` snd (machOpProps mop) + +-- If in doubt, return False. This generates worse code on the +-- native routes, but is otherwise harmless. +isComparisonMachOp :: MachOp -> Bool +isComparisonMachOp mop = comp `elem` snd (machOpProps mop) + +-- Find the PrimReps for the returned value(s) of the MachOp. +resultRepsOfMachOp :: MachOp -> Maybe012 PrimRep +resultRepsOfMachOp mop = fst (machOpProps mop) + +-- This bit does the real work. +machOpProps :: MachOp -> (Maybe012 PrimRep, [MO_Prop]) + +machOpProps MO_Nat_Add = (Just1 IntRep, [inline, comm]) +machOpProps MO_Nat_Sub = (Just1 IntRep, [inline]) +machOpProps MO_Nat_Eq = (Just1 IntRep, [inline, comp, comm]) +machOpProps MO_Nat_Ne = (Just1 IntRep, [inline, comp, comm]) + +machOpProps MO_NatS_Ge = (Just1 IntRep, [inline, comp]) +machOpProps MO_NatS_Le = (Just1 IntRep, [inline, comp]) +machOpProps MO_NatS_Gt = (Just1 IntRep, [inline, comp]) +machOpProps MO_NatS_Lt = (Just1 IntRep, [inline, comp]) + +machOpProps MO_NatU_Ge = (Just1 IntRep, [inline, comp]) +machOpProps MO_NatU_Le = (Just1 IntRep, [inline, comp]) +machOpProps MO_NatU_Gt = (Just1 IntRep, [inline, comp]) +machOpProps MO_NatU_Lt = (Just1 IntRep, [inline, comp]) + +machOpProps MO_NatS_Mul = (Just1 IntRep, [inline, comm]) +machOpProps MO_NatS_Quot = (Just1 IntRep, [inline]) +machOpProps MO_NatS_Rem = (Just1 IntRep, [inline]) +machOpProps MO_NatS_Neg = (Just1 IntRep, [inline]) + +machOpProps MO_NatU_Mul = (Just1 WordRep, [inline, comm]) +machOpProps MO_NatU_Quot = (Just1 WordRep, [inline]) +machOpProps MO_NatU_Rem = (Just1 WordRep, [inline]) + +machOpProps MO_NatS_AddC = (Just2 IntRep IntRep, []) +machOpProps MO_NatS_SubC = (Just2 IntRep IntRep, []) +machOpProps MO_NatS_MulC = (Just2 IntRep IntRep, []) + +machOpProps MO_Nat_And = (Just1 IntRep, [inline, comm]) +machOpProps MO_Nat_Or = (Just1 IntRep, [inline, comm]) +machOpProps MO_Nat_Xor = (Just1 IntRep, [inline, comm]) +machOpProps MO_Nat_Not = (Just1 IntRep, [inline]) +machOpProps MO_Nat_Shl = (Just1 IntRep, [inline]) +machOpProps MO_Nat_Shr = (Just1 IntRep, [inline]) +machOpProps MO_Nat_Sar = (Just1 IntRep, [inline]) + +machOpProps MO_32U_Eq = (Just1 IntRep, [inline, comp, comm]) +machOpProps MO_32U_Ne = (Just1 IntRep, [inline, comp, comm]) +machOpProps MO_32U_Ge = (Just1 IntRep, [inline, comp]) +machOpProps MO_32U_Le = (Just1 IntRep, [inline, comp]) +machOpProps MO_32U_Gt = (Just1 IntRep, [inline, comp]) +machOpProps MO_32U_Lt = (Just1 IntRep, [inline, comp]) + +machOpProps MO_Dbl_Eq = (Just1 IntRep, [inline, comp, comm]) +machOpProps MO_Dbl_Ne = (Just1 IntRep, [inline, comp, comm]) +machOpProps MO_Dbl_Ge = (Just1 IntRep, [inline, comp]) +machOpProps MO_Dbl_Le = (Just1 IntRep, [inline, comp]) +machOpProps MO_Dbl_Gt = (Just1 IntRep, [inline, comp]) +machOpProps MO_Dbl_Lt = (Just1 IntRep, [inline, comp]) + +machOpProps MO_Dbl_Add = (Just1 DoubleRep, [inline, comm]) +machOpProps MO_Dbl_Sub = (Just1 DoubleRep, [inline]) +machOpProps MO_Dbl_Mul = (Just1 DoubleRep, [inline, comm]) +machOpProps MO_Dbl_Div = (Just1 DoubleRep, [inline]) +machOpProps MO_Dbl_Pwr = (Just1 DoubleRep, []) + +machOpProps MO_Dbl_Sin = (Just1 DoubleRep, []) +machOpProps MO_Dbl_Cos = (Just1 DoubleRep, []) +machOpProps MO_Dbl_Tan = (Just1 DoubleRep, []) +machOpProps MO_Dbl_Sinh = (Just1 DoubleRep, []) +machOpProps MO_Dbl_Cosh = (Just1 DoubleRep, []) +machOpProps MO_Dbl_Tanh = (Just1 DoubleRep, []) +machOpProps MO_Dbl_Asin = (Just1 DoubleRep, []) +machOpProps MO_Dbl_Acos = (Just1 DoubleRep, []) +machOpProps MO_Dbl_Atan = (Just1 DoubleRep, []) +machOpProps MO_Dbl_Log = (Just1 DoubleRep, []) +machOpProps MO_Dbl_Exp = (Just1 DoubleRep, []) +machOpProps MO_Dbl_Sqrt = (Just1 DoubleRep, []) +machOpProps MO_Dbl_Neg = (Just1 DoubleRep, [inline]) + +machOpProps MO_Flt_Add = (Just1 FloatRep, [inline, comm]) +machOpProps MO_Flt_Sub = (Just1 FloatRep, [inline]) +machOpProps MO_Flt_Mul = (Just1 FloatRep, [inline, comm]) +machOpProps MO_Flt_Div = (Just1 FloatRep, [inline]) +machOpProps MO_Flt_Pwr = (Just1 FloatRep, []) + +machOpProps MO_Flt_Eq = (Just1 IntRep, [inline, comp, comm]) +machOpProps MO_Flt_Ne = (Just1 IntRep, [inline, comp, comm]) +machOpProps MO_Flt_Ge = (Just1 IntRep, [inline, comp]) +machOpProps MO_Flt_Le = (Just1 IntRep, [inline, comp]) +machOpProps MO_Flt_Gt = (Just1 IntRep, [inline, comp]) +machOpProps MO_Flt_Lt = (Just1 IntRep, [inline, comp]) + +machOpProps MO_Flt_Sin = (Just1 FloatRep, []) +machOpProps MO_Flt_Cos = (Just1 FloatRep, []) +machOpProps MO_Flt_Tan = (Just1 FloatRep, []) +machOpProps MO_Flt_Sinh = (Just1 FloatRep, []) +machOpProps MO_Flt_Cosh = (Just1 FloatRep, []) +machOpProps MO_Flt_Tanh = (Just1 FloatRep, []) +machOpProps MO_Flt_Asin = (Just1 FloatRep, []) +machOpProps MO_Flt_Acos = (Just1 FloatRep, []) +machOpProps MO_Flt_Atan = (Just1 FloatRep, []) +machOpProps MO_Flt_Log = (Just1 FloatRep, []) +machOpProps MO_Flt_Exp = (Just1 FloatRep, []) +machOpProps MO_Flt_Sqrt = (Just1 FloatRep, []) +machOpProps MO_Flt_Neg = (Just1 FloatRep, [inline]) + +machOpProps MO_32U_to_NatS = (Just1 IntRep, [inline]) +machOpProps MO_NatS_to_32U = (Just1 WordRep, [inline]) + +machOpProps MO_NatS_to_Dbl = (Just1 DoubleRep, [inline]) +machOpProps MO_Dbl_to_NatS = (Just1 IntRep, [inline]) + +machOpProps MO_NatS_to_Flt = (Just1 FloatRep, [inline]) +machOpProps MO_Flt_to_NatS = (Just1 IntRep, [inline]) + +machOpProps MO_NatS_to_NatU = (Just1 WordRep, [inline]) +machOpProps MO_NatU_to_NatS = (Just1 IntRep, [inline]) + +machOpProps MO_NatS_to_NatP = (Just1 PtrRep, [inline]) +machOpProps MO_NatP_to_NatS = (Just1 IntRep, [inline]) +machOpProps MO_NatU_to_NatP = (Just1 PtrRep, [inline]) +machOpProps MO_NatP_to_NatU = (Just1 WordRep, [inline]) + +machOpProps MO_Dbl_to_Flt = (Just1 FloatRep, [inline]) +machOpProps MO_Flt_to_Dbl = (Just1 DoubleRep, [inline]) + +machOpProps MO_8S_to_NatS = (Just1 IntRep, [inline]) +machOpProps MO_16S_to_NatS = (Just1 IntRep, [inline]) +machOpProps MO_32S_to_NatS = (Just1 IntRep, [inline]) + +machOpProps MO_8U_to_NatU = (Just1 WordRep, [inline]) +machOpProps MO_16U_to_NatU = (Just1 WordRep, [inline]) +machOpProps MO_32U_to_NatU = (Just1 WordRep, [inline]) + +machOpProps (MO_ReadOSBI offset rep) = (Just1 rep, [inline]) +machOpProps (MO_WriteOSBI offset rep) = (Just0, [inline]) + + + diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs index 765971f244..48a90b4b1b 100644 --- a/ghc/compiler/absCSyn/PprAbsC.lhs +++ b/ghc/compiler/absCSyn/PprAbsC.lhs @@ -19,13 +19,14 @@ module PprAbsC ( import IO ( Handle ) +import PrimRep import AbsCSyn import ClosureInfo import AbsCUtils ( getAmodeRep, nonemptyAbsC, mixedPtrLocn, mixedTypeLocn ) -import Constants ( mIN_UPD_SIZE ) +import Constants ( mIN_UPD_SIZE, wORD_SIZE ) import ForeignCall ( CCallSpec(..), CCallTarget(..), playSafe, ccallConvAttribute ) import CLabel ( externallyVisibleCLabel, needsCDecl, pprCLabel, @@ -44,10 +45,11 @@ import Literal ( Literal(..) ) import TyCon ( tyConDataCons ) import Name ( NamedThing(..) ) import DataCon ( dataConWrapId ) -import Maybes ( maybeToBool, catMaybes ) +import Maybes ( Maybe012(..), maybe012ToList, maybeToBool, catMaybes ) import PrimOp ( primOpNeedsWrapper ) +import MachOp ( MachOp(..) ) import ForeignCall ( ForeignCall(..) ) -import PrimRep ( isFloatingRep, PrimRep(..), getPrimRepSize ) +import PrimRep ( isFloatingRep, PrimRep(..), getPrimRepSize, getPrimRepArrayElemSize ) import SMRep ( pprSMRep ) import Unique ( pprUnique, Unique{-instance NamedThing-} ) import UniqSet ( emptyUniqSet, elementOfUniqSet, @@ -58,6 +60,7 @@ import BitSet ( BitSet, intBS ) import Outputable import GlaExts import Util ( nOfThem, lengthExceeds, listLengthCmp ) +import Maybe ( isNothing ) import ST @@ -249,6 +252,70 @@ pprAbsC stmt@(COpStmt results (StgPrimOp op) args vol_regs) _ -- primop macros do their own casting of result; -- hence we can toss the provided cast... +-- NEW CASES FOR EXPANDED PRIMOPS + +-- We have to deal with some of these specially +pprAbsC (CMachOpStmt (Just1 res) (MO_ReadOSBI offw scaleRep) + [baseAmode, indexAmode] maybe_vols) + _ + | isNothing maybe_vols + = hcat [ -- text " /* ReadOSBI */ ", + ppr_amode res, equals, + ppr_array_expression offw scaleRep baseAmode indexAmode, + semi ] + | otherwise + = panic "pprAbsC:MO_ReadOSBI -- out-of-line array indexing ?!?!" + +pprAbsC (CMachOpStmt Just0 (MO_WriteOSBI offw scaleRep) + [baseAmode, indexAmode, vAmode] maybe_vols) + _ + | isNothing maybe_vols + = hcat [ -- text " /* WriteOSBI */ ", + ppr_array_expression offw scaleRep baseAmode indexAmode, + equals, pprAmode vAmode, + semi ] + | otherwise + = panic "pprAbsC:MO_WriteOSBI -- out-of-line array indexing ?!?!" + +pprAbsC (CMachOpStmt (Just2 res carry) mop [arg1,arg2] maybe_vols) _ + | mop `elem` [MO_NatS_AddC, MO_NatS_SubC, MO_NatS_MulC] + = hcat [ pprMachOp_for_C mop, + lparen, + ppr_amode res, comma, ppr_amode carry, comma, + pprAmode arg1, comma, pprAmode arg2, + rparen, semi ] + +-- The rest generically. + +pprAbsC stmt@(CMachOpStmt (Just1 res) mop [arg1,arg2] maybe_vols) _ + = let prefix_fn = mop `elem` [MO_Dbl_Pwr, MO_Flt_Pwr] + in + case ppr_maybe_vol_regs maybe_vols of {(saves,restores) -> + saves $$ + hcat ( + [ppr_amode res, equals] + ++ (if prefix_fn + then [pprMachOp_for_C mop, parens (pprAmode arg1 <> comma <> pprAmode arg2)] + else [pprAmode arg1, pprMachOp_for_C mop, pprAmode arg2]) + ++ [semi] + ) + $$ restores + } + +pprAbsC stmt@(CMachOpStmt (Just1 res) mop [arg1] maybe_vols) _ + = case ppr_maybe_vol_regs maybe_vols of {(saves,restores) -> + saves $$ + hcat [ppr_amode res, equals, + pprMachOp_for_C mop, parens (pprAmode arg1), + semi] + $$ restores + } + +pprAbsC stmt@(CSequential stuff) c + = vcat (map (flip pprAbsC c) stuff) + +-- end of NEW CASES FOR EXPANDED PRIMOPS + pprAbsC stmt@(CSRT lbl closures) c = case (pprTempAndExternDecls stmt) of { (_, pp_exts) -> pp_exts @@ -580,6 +647,151 @@ pprAbsC (CCostCentreStackDecl ccs) _ = pprCostCentreStackDecl ccs \end{code} \begin{code} +-- Print a CMachOp in a way suitable for emitting via C. +pprMachOp_for_C MO_Nat_Add = char '+' +pprMachOp_for_C MO_Nat_Sub = char '-' +pprMachOp_for_C MO_Nat_Eq = text "==" +pprMachOp_for_C MO_Nat_Ne = text "!=" + +pprMachOp_for_C MO_NatS_Ge = text ">=" +pprMachOp_for_C MO_NatS_Le = text "<=" +pprMachOp_for_C MO_NatS_Gt = text ">" +pprMachOp_for_C MO_NatS_Lt = text "<" + +pprMachOp_for_C MO_NatU_Ge = text ">=" +pprMachOp_for_C MO_NatU_Le = text "<=" +pprMachOp_for_C MO_NatU_Gt = text ">" +pprMachOp_for_C MO_NatU_Lt = text "<" + +pprMachOp_for_C MO_NatS_Mul = char '*' +pprMachOp_for_C MO_NatS_Quot = char '/' +pprMachOp_for_C MO_NatS_Rem = char '%' +pprMachOp_for_C MO_NatS_Neg = char '-' + +pprMachOp_for_C MO_NatU_Mul = char '*' +pprMachOp_for_C MO_NatU_Quot = char '/' +pprMachOp_for_C MO_NatU_Rem = char '%' + +pprMachOp_for_C MO_NatS_AddC = text "addIntCzh" +pprMachOp_for_C MO_NatS_SubC = text "subIntCzh" +pprMachOp_for_C MO_NatS_MulC = text "mulIntCzh" + +pprMachOp_for_C MO_Nat_And = text "&" +pprMachOp_for_C MO_Nat_Or = text "|" +pprMachOp_for_C MO_Nat_Xor = text "^" +pprMachOp_for_C MO_Nat_Not = text "~" +pprMachOp_for_C MO_Nat_Shl = text "<<" +pprMachOp_for_C MO_Nat_Shr = text ">>" +pprMachOp_for_C MO_Nat_Sar = text ">>" + +pprMachOp_for_C MO_32U_Eq = text "==" +pprMachOp_for_C MO_32U_Ne = text "!=" +pprMachOp_for_C MO_32U_Ge = text ">=" +pprMachOp_for_C MO_32U_Le = text "<=" +pprMachOp_for_C MO_32U_Gt = text ">" +pprMachOp_for_C MO_32U_Lt = text "<" + +pprMachOp_for_C MO_Dbl_Eq = text "==" +pprMachOp_for_C MO_Dbl_Ne = text "!=" +pprMachOp_for_C MO_Dbl_Ge = text ">=" +pprMachOp_for_C MO_Dbl_Le = text "<=" +pprMachOp_for_C MO_Dbl_Gt = text ">" +pprMachOp_for_C MO_Dbl_Lt = text "<" + +pprMachOp_for_C MO_Dbl_Add = text "+" +pprMachOp_for_C MO_Dbl_Sub = text "-" +pprMachOp_for_C MO_Dbl_Mul = text "*" +pprMachOp_for_C MO_Dbl_Div = text "/" +pprMachOp_for_C MO_Dbl_Pwr = text "pow" + +pprMachOp_for_C MO_Dbl_Sin = text "sin" +pprMachOp_for_C MO_Dbl_Cos = text "cos" +pprMachOp_for_C MO_Dbl_Tan = text "tan" +pprMachOp_for_C MO_Dbl_Sinh = text "sinh" +pprMachOp_for_C MO_Dbl_Cosh = text "cosh" +pprMachOp_for_C MO_Dbl_Tanh = text "tanh" +pprMachOp_for_C MO_Dbl_Asin = text "asin" +pprMachOp_for_C MO_Dbl_Acos = text "acos" +pprMachOp_for_C MO_Dbl_Atan = text "atan" +pprMachOp_for_C MO_Dbl_Log = text "log" +pprMachOp_for_C MO_Dbl_Exp = text "exp" +pprMachOp_for_C MO_Dbl_Sqrt = text "sqrt" +pprMachOp_for_C MO_Dbl_Neg = text "-" + +pprMachOp_for_C MO_Flt_Add = text "+" +pprMachOp_for_C MO_Flt_Sub = text "-" +pprMachOp_for_C MO_Flt_Mul = text "*" +pprMachOp_for_C MO_Flt_Div = text "/" +pprMachOp_for_C MO_Flt_Pwr = text "pow" + +pprMachOp_for_C MO_Flt_Eq = text "==" +pprMachOp_for_C MO_Flt_Ne = text "!=" +pprMachOp_for_C MO_Flt_Ge = text ">=" +pprMachOp_for_C MO_Flt_Le = text "<=" +pprMachOp_for_C MO_Flt_Gt = text ">" +pprMachOp_for_C MO_Flt_Lt = text "<" + +pprMachOp_for_C MO_Flt_Sin = text "sin" +pprMachOp_for_C MO_Flt_Cos = text "cos" +pprMachOp_for_C MO_Flt_Tan = text "tan" +pprMachOp_for_C MO_Flt_Sinh = text "sinh" +pprMachOp_for_C MO_Flt_Cosh = text "cosh" +pprMachOp_for_C MO_Flt_Tanh = text "tanh" +pprMachOp_for_C MO_Flt_Asin = text "asin" +pprMachOp_for_C MO_Flt_Acos = text "acos" +pprMachOp_for_C MO_Flt_Atan = text "atan" +pprMachOp_for_C MO_Flt_Log = text "log" +pprMachOp_for_C MO_Flt_Exp = text "exp" +pprMachOp_for_C MO_Flt_Sqrt = text "sqrt" +pprMachOp_for_C MO_Flt_Neg = text "-" + +pprMachOp_for_C MO_32U_to_NatS = text "(StgInt)" +pprMachOp_for_C MO_NatS_to_32U = text "(StgWord32)" + +pprMachOp_for_C MO_NatS_to_Dbl = text "(StgDouble)" +pprMachOp_for_C MO_Dbl_to_NatS = text "(StgInt)" + +pprMachOp_for_C MO_NatS_to_Flt = text "(StgFloat)" +pprMachOp_for_C MO_Flt_to_NatS = text "(StgInt)" + +pprMachOp_for_C MO_NatS_to_NatU = text "(StgWord)" +pprMachOp_for_C MO_NatU_to_NatS = text "(StgInt)" + +pprMachOp_for_C MO_NatS_to_NatP = text "(void*)" +pprMachOp_for_C MO_NatP_to_NatS = text "(StgInt)" +pprMachOp_for_C MO_NatU_to_NatP = text "(void*)" +pprMachOp_for_C MO_NatP_to_NatU = text "(StgWord)" + +pprMachOp_for_C MO_Dbl_to_Flt = text "(StgFloat)" +pprMachOp_for_C MO_Flt_to_Dbl = text "(StgDouble)" + +pprMachOp_for_C MO_8S_to_NatS = text "(StgInt8)(StgInt)" +pprMachOp_for_C MO_16S_to_NatS = text "(StgInt16)(StgInt)" +pprMachOp_for_C MO_32S_to_NatS = text "(StgInt32)(StgInt)" + +pprMachOp_for_C MO_8U_to_NatU = text "(StgWord8)(StgWord)" +pprMachOp_for_C MO_16U_to_NatU = text "(StgWord16)(StgWord)" +pprMachOp_for_C MO_32U_to_NatU = text "(StgWord32)(StgWord)" + +pprMachOp_for_C (MO_ReadOSBI _ _) = panic "pprMachOp_for_C:MO_ReadOSBI" +pprMachOp_for_C (MO_WriteOSBI _ _) = panic "pprMachOp_for_C:MO_WriteOSBI" + + +-- Helper for printing array expressions. +ppr_array_expression offw scaleRep baseAmode indexAmode + -- create: + -- * (scaleRep*) ( + -- ((char*)baseAmode) + offw*bytes_per_word + indexAmode*bytes_per_scaleRep + -- ) + = let offb = parens (int offw <> char '*' <> int wORD_SIZE) + indb = parens (parens (pprAmode indexAmode) + <> char '*' <> int (getPrimRepArrayElemSize scaleRep)) + baseb = text "(char*)" <> parens (pprAmode baseAmode) + addr = parens baseb <+> char '+' <+> offb <+> char '+' <+> indb + in + char '*' <> parens (ppr scaleRep <> char '*') <> parens addr + + ppLocalness lbl = if (externallyVisibleCLabel lbl) then empty @@ -626,6 +838,15 @@ non_void amode \end{code} \begin{code} +ppr_maybe_vol_regs :: Maybe [MagicId] -> (SDoc, SDoc) +ppr_maybe_vol_regs Nothing + = (empty, empty) +ppr_maybe_vol_regs (Just vrs) + = case ppr_vol_regs vrs of + (saves, restores) + -> (pp_basic_saves $$ saves, + pp_basic_restores $$ restores) + ppr_vol_regs :: [MagicId] -> (SDoc, SDoc) ppr_vol_regs [] = (empty, empty) @@ -677,33 +898,27 @@ if_profiling pretty -- --------------------------------------------------------------------------- do_if_stmt discrim tag alt_code deflt c - = case tag of - -- This special case happens when testing the result of a comparison. - -- We can just avoid some redundant clutter in the output. - MachInt n | n==0 -> ppr_if_stmt (pprAmode discrim) - deflt alt_code - (addrModeCosts discrim Rhs) c - other -> let - cond = hcat [ pprAmode discrim - , ptext SLIT(" == ") - , tcast - , pprAmode (CLit tag) - ] - -- to be absolutely sure that none of the - -- conversion rules hit, e.g., - -- - -- minInt is different to (int)minInt - -- - -- in C (when minInt is a number not a constant - -- expression which evaluates to it.) - -- - tcast = case other of - MachInt _ -> ptext SLIT("(I_)") - _ -> empty - in - ppr_if_stmt cond - alt_code deflt - (addrModeCosts discrim Rhs) c + = let + cond = hcat [ pprAmode discrim + , ptext SLIT(" == ") + , tcast + , pprAmode (CLit tag) + ] + -- to be absolutely sure that none of the + -- conversion rules hit, e.g., + -- + -- minInt is different to (int)minInt + -- + -- in C (when minInt is a number not a constant + -- expression which evaluates to it.) + -- + tcast = case tag of + MachInt _ -> ptext SLIT("(I_)") + _ -> empty + in + ppr_if_stmt cond + alt_code deflt + (addrModeCosts discrim Rhs) c ppr_if_stmt pp_pred then_part else_part discrim_costs c = vcat [ @@ -1093,6 +1308,10 @@ That is, the indexing is done in units of kind1, but the resulting amode has kind2. \begin{code} +ppr_amode (CMem rep addr) + = let txt_rep = pprPrimKind rep + in hcat [ char '*', parens (txt_rep <> char '*'), parens (ppr_amode addr) ] + ppr_amode (CVal reg_rel@(CIndex _ _ _) kind) = case (pprRegRelative False{-no sign wanted-} reg_rel) of (pp_reg, Nothing) -> panic "ppr_amode: CIndex" @@ -1177,6 +1396,9 @@ cCheckMacroText HP_CHK_UT_ALT = SLIT("HP_CHK_UT_ALT") cCheckMacroText HP_CHK_GEN = SLIT("HP_CHK_GEN") \end{code} +\begin{code} +\end{code} + %************************************************************************ %* * \subsection[ppr-liveness-masks]{Liveness Masks} @@ -1493,9 +1715,15 @@ ppr_decls_AbsC (CInitHdr cl_info reg_rel cost_centre _) where info_lbl = infoTableLabelFromCI cl_info +ppr_decls_AbsC (CMachOpStmt res _ args _) = ppr_decls_Amodes (maybe012ToList res ++ args) ppr_decls_AbsC (COpStmt results _ args _) = ppr_decls_Amodes (results ++ args) + ppr_decls_AbsC (CSimultaneous abc) = ppr_decls_AbsC abc +ppr_decls_AbsC (CSequential abcs) + = mapTE ppr_decls_AbsC abcs `thenTE` \ t_and_e_s -> + returnTE (maybe_vcat t_and_e_s) + ppr_decls_AbsC (CCheck _ amodes code) = ppr_decls_Amodes amodes `thenTE` \p1 -> ppr_decls_AbsC code `thenTE` \p2 -> diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs index 379c39719d..a863c75f7e 100644 --- a/ghc/compiler/codeGen/CgCase.lhs +++ b/ghc/compiler/codeGen/CgCase.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgCase.lhs,v 1.54 2001/10/11 14:31:45 sewardj Exp $ +% $Id: CgCase.lhs,v 1.55 2001/12/05 17:35:13 sewardj Exp $ % %******************************************************** %* * @@ -156,7 +156,8 @@ cgCase (StgOpApp op args _) tag_amode = CTemp (newTagUnique (getUnique bndr) 'C') IntRep in getVolatileRegs live_in_alts `thenFC` \ vol_regs -> - absC (COpStmt [tag_amode] op arg_amodes vol_regs) `thenC` + absC (COpStmt [tag_amode] op arg_amodes vol_regs) + `thenC` -- NB: no liveness arg returnFC tag_amode } `thenFC` \ tag_amode -> diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs index dbd6bf13e9..c8beedd89f 100644 --- a/ghc/compiler/main/ErrUtils.lhs +++ b/ghc/compiler/main/ErrUtils.lhs @@ -29,7 +29,7 @@ import CmdLineOpts ( DynFlags(..), DynFlag(..), dopt ) import List ( replicate ) import System ( ExitCode(..), exitWith ) -import IO ( hPutStr, hPutStrLn, stderr ) +import IO ( hPutStr, hPutStrLn, stderr, stdout ) \end{code} \begin{code} @@ -146,8 +146,12 @@ dumpIfSet_core dflags flag hdr doc dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO () dumpIfSet_dyn dflags flag hdr doc - | dopt flag dflags || verbosity dflags >= 4 = printDump (dump hdr doc) - | otherwise = return () + | dopt flag dflags || verbosity dflags >= 4 + = if flag `elem` [Opt_D_dump_stix, Opt_D_dump_asm] + then printForC stdout (dump hdr doc) + else printDump (dump hdr doc) + | otherwise + = return () dumpIfSet_dyn_or :: DynFlags -> [DynFlag] -> String -> SDoc -> IO () dumpIfSet_dyn_or dflags flags hdr doc diff --git a/ghc/compiler/nativeGen/AbsCStixGen.lhs b/ghc/compiler/nativeGen/AbsCStixGen.lhs index 5ee35ab29d..aee085aff6 100644 --- a/ghc/compiler/nativeGen/AbsCStixGen.lhs +++ b/ghc/compiler/nativeGen/AbsCStixGen.lhs @@ -21,7 +21,7 @@ import SMRep ( fixedItblSize, rET_SMALL, rET_BIG, rET_VEC_SMALL, rET_VEC_BIG ) -import Constants ( mIN_UPD_SIZE ) +import Constants ( mIN_UPD_SIZE, wORD_SIZE ) import CLabel ( CLabel, mkReturnInfoLabel, mkReturnPtLabel, mkClosureTblLabel, mkClosureLabel, labelDynamic, mkSplitMarkerLabel ) @@ -30,14 +30,14 @@ import ClosureInfo ( infoTableLabelFromCI, entryLabelFromCI, staticClosureNeedsLink ) import Literal ( Literal(..), word2IntLit ) -import Maybes ( maybeToBool ) +import Maybes ( Maybe012(..), maybeToBool ) import StgSyn ( StgOp(..) ) -import PrimOp ( primOpNeedsWrapper, PrimOp(..) ) +import MachOp ( MachOp(..), resultRepsOfMachOp ) import PrimRep ( isFloatingRep, PrimRep(..) ) import StixInfo ( genCodeInfoTable, genBitmapInfoTable, livenessIsSmall, bitmapToIntegers ) import StixMacro ( macroCode, checkCode ) -import StixPrim ( primCode, foreignCallCode, amodeToStix, amodeToStix' ) +import StixPrim ( foreignCallCode, amodeToStix, amodeToStix' ) import Outputable ( pprPanic, ppr ) import UniqSupply ( returnUs, thenUs, mapUs, getUniqueUs, UniqSM ) import Util ( naturalMergeSortLe ) @@ -47,6 +47,12 @@ import DataCon ( dataConWrapId ) import Name ( NamedThing(..) ) import CmdLineOpts ( opt_Static, opt_EnsureSplittableC ) import Outputable ( assertPanic ) + +-- DEBUGGING ONLY +--import IOExts ( trace ) +--import Outputable ( showSDoc ) +--import MachOp ( pprMachOp ) + \end{code} For each independent chunk of AbstractC code, we generate a list of @@ -55,7 +61,7 @@ We leave the chunks separated so that register allocation can be performed locally within the chunk. \begin{code} -genCodeAbstractC :: AbstractC -> UniqSM [StixTree] +genCodeAbstractC :: AbstractC -> UniqSM [StixStmt] genCodeAbstractC absC = gentopcode absC @@ -64,7 +70,6 @@ genCodeAbstractC absC a2stix' = amodeToStix' volsaves = volatileSaves volrestores = volatileRestores - p2stix = primCode macro_code = macroCode -- real code follows... --------- \end{code} @@ -151,7 +156,7 @@ Here we handle top-level things, like @CCodeBlock@s and , StData DataPtrRep (map mk_StCLbl_for_SRT closures) ] where - mk_StCLbl_for_SRT :: CLabel -> StixTree + mk_StCLbl_for_SRT :: CLabel -> StixExpr mk_StCLbl_for_SRT label | labelDynamic label = StIndex Int8Rep (StCLbl label) (StInt 1) @@ -183,15 +188,15 @@ Here we handle top-level things, like @CCodeBlock@s and : StData IntRep [StInt 0] : StSegment TextSegment : StLabel lbl - : StCondJump tmp_lbl (StPrim IntNeOp + : StCondJump tmp_lbl (StMachOp MO_Nat_Ne [StInd IntRep (StCLbl flag_lbl), StInt 0]) - : StAssign IntRep (StInd IntRep (StCLbl flag_lbl)) (StInt 1) + : StAssignMem IntRep (StCLbl flag_lbl) (StInt 1) : code [ StLabel tmp_lbl - , StAssign PtrRep stgSp - (StIndex PtrRep stgSp (StInt (-1))) - , StJump NoDestInfo (StInd WordRep stgSp) + , StAssignReg PtrRep stgSp + (StIndex PtrRep (StReg stgSp) (StInt (-1))) + , StJump NoDestInfo (StInd WordRep (StReg stgSp)) ]) gentopcode absC @@ -294,6 +299,14 @@ resulting StixTreeLists are joined together. gencode c2 `thenUs` \ b2 -> returnUs (b1 . b2) + gencode (CSequential stuff) + = foo stuff + where + foo [] = returnUs id + foo (s:ss) = gencode s `thenUs` \ stix -> + foo ss `thenUs` \ stixes -> + returnUs (stix . stixes) + \end{code} Initialising closure headers in the heap...a fairly complex ordeal if @@ -309,7 +322,7 @@ addresses, etc.) lhs = a2stix reg_rel lbl = infoTableLabelFromCI cl_info in - returnUs (\xs -> StAssign PtrRep (StInd PtrRep lhs) (StCLbl lbl) : xs) + returnUs (\xs -> StAssignMem PtrRep lhs (StCLbl lbl) : xs) \end{code} @@ -340,7 +353,7 @@ of the source? Be careful about floats/doubles. lhs' = a2stix lhs rhs' = a2stix' rhs in - returnUs (\xs -> StAssign pk' lhs' rhs' : xs) + returnUs (\xs -> mkStAssign pk' lhs' rhs' : xs) \end{code} @@ -373,8 +386,8 @@ which varies depending on whether we're profiling etc. = returnUs (\xs -> StJump NoDestInfo dest : xs) where dest = StInd PtrRep (StIndex PtrRep (a2stix table) dyn_off) - dyn_off = StPrim IntSubOp [StPrim IntNegOp [a2stix am], - StInt (toInteger (fixedItblSize+1))] + dyn_off = StMachOp MO_Nat_Sub [StMachOp MO_NatS_Neg [a2stix am], + StInt (toInteger (fixedItblSize+1))] \end{code} @@ -386,17 +399,60 @@ Now the PrimOps, some of which may need caller-saves register wrappers. foreignCallCode (nonVoid results) fcall (nonVoid args) gencode (COpStmt results (StgPrimOp op) args vols) - -- ToDo (ADR?): use that liveness mask - | primOpNeedsWrapper op - = let - saves = volsaves vols - restores = volrestores vols + = panic "AbsCStixGen.gencode: un-translated PrimOp" + + -- Translate out array indexing primops right here, so that + -- individual targets don't have to deal with them + + gencode (CMachOpStmt (Just1 r1) (MO_ReadOSBI off_w rep) [base,index] vols) + = returnUs (\xs -> + mkStAssign + rep + (a2stix r1) + (StInd rep (StMachOp MO_Nat_Add + [StIndex rep (a2stix base) (a2stix index), + StInt (toInteger (off_w * wORD_SIZE))])) + : xs + ) + + gencode (CMachOpStmt Just0 (MO_WriteOSBI off_w rep) [base,index,val] vols) + = returnUs (\xs -> + StAssignMem + rep + (StMachOp MO_Nat_Add + [StIndex rep (a2stix base) (a2stix index), + StInt (toInteger (off_w * wORD_SIZE))]) + (a2stix val) + : xs + ) + + -- Gruesome cases for multiple-result primops + gencode (CMachOpStmt (Just2 r1 r2) mop [arg1, arg2] vols) + | mop `elem` [MO_NatS_AddC, MO_NatS_SubC, MO_NatS_MulC] + = getUniqueUs `thenUs` \ u1 -> + getUniqueUs `thenUs` \ u2 -> + let vr1 = StixVReg u1 IntRep + vr2 = StixVReg u2 IntRep + r1s = a2stix r1 + r2s = a2stix r2 in - p2stix (nonVoid results) op (nonVoid args) - `thenUs` \ code -> - returnUs (\xs -> saves ++ code (restores ++ xs)) + returnUs (\xs -> + StAssignMachOp (Just2 vr1 vr2) mop [a2stix arg1, a2stix arg2] + : mkStAssign IntRep r1s (StReg (StixTemp vr1)) + : mkStAssign IntRep r2s (StReg (StixTemp vr2)) + : xs + ) + + -- Ordinary MachOps are passed through unchanged. - | otherwise = p2stix (nonVoid results) op (nonVoid args) + gencode (CMachOpStmt (Just1 r1) mop args vols) + = let (Just1 rep) = resultRepsOfMachOp mop + in + returnUs (\xs -> + mkStAssign rep (a2stix r1) + (StMachOp mop (map a2stix args)) + : xs + ) \end{code} Now the dreaded conditional jump. @@ -564,10 +620,10 @@ already finish with a jump to the join point. mkJumpTable am alts lowTag highTag dflt = getUniqLabelNCG `thenUs` \ utlbl -> mapUs genLabel alts `thenUs` \ branches -> - let cjmpLo = StCondJump dflt (StPrim IntLtOp [am, StInt (toInteger lowTag)]) - cjmpHi = StCondJump dflt (StPrim IntGtOp [am, StInt (toInteger highTag)]) + let cjmpLo = StCondJump dflt (StMachOp MO_NatS_Lt [am, StInt (toInteger lowTag)]) + cjmpHi = StCondJump dflt (StMachOp MO_NatS_Gt [am, StInt (toInteger highTag)]) - offset = StPrim IntSubOp [am, StInt lowTag] + offset = StMachOp MO_Nat_Sub [am, StInt lowTag] dsts = DestInfo (dflt : map fst branches) jump = StJump dsts (StInd PtrRep (StIndex PtrRep (StCLbl utlbl) offset)) @@ -624,8 +680,8 @@ alternatives should already finish with a jump to the join point. | rangeOfOne = gencode alt | otherwise = let tag' = a2stix (CLit tag) - cmpOp = if floating then DoubleNeOp else IntNeOp - test = StPrim cmpOp [am, tag'] + cmpOp = if floating then MO_Dbl_Ne else MO_Nat_Ne + test = StMachOp cmpOp [am, tag'] cjmp = StCondJump udlbl test in gencode alt `thenUs` \ alt_code -> @@ -638,8 +694,8 @@ alternatives should already finish with a jump to the join point. mkBinaryTree am floating alts choices lowTag highTag udlbl = getUniqLabelNCG `thenUs` \ uhlbl -> let tag' = a2stix (CLit splitTag) - cmpOp = if floating then DoubleGeOp else IntGeOp - test = StPrim cmpOp [am, tag'] + cmpOp = if floating then MO_Dbl_Ge else MO_NatS_Ge + test = StMachOp cmpOp [am, tag'] cjmp = StCondJump uhlbl test in mkBinaryTree am floating alts_lo half lowTag splitTag udlbl @@ -671,8 +727,8 @@ alternatives should already finish with a jump to the join point. getUniqLabelNCG `thenUs` \ utlbl -> let discrim' = a2stix discrim tag' = a2stix (CLit tag) - cmpOp = if (isFloatingRep (getAmodeRep discrim)) then DoubleNeOp else IntNeOp - test = StPrim cmpOp [discrim', tag'] + cmpOp = if (isFloatingRep (getAmodeRep discrim)) then MO_Dbl_Ne else MO_Nat_Ne + test = StMachOp cmpOp [discrim', tag'] cjmp = StCondJump utlbl test dest = StLabel utlbl join = StLabel ujlbl @@ -681,8 +737,8 @@ alternatives should already finish with a jump to the join point. gencode deflt `thenUs` \ dflt_code -> returnUs (\xs -> cjmp : alt_code (dest : dflt_code (join : xs))) -mkJoin :: AbstractC -> CLabel -> AbstractC +mkJoin :: AbstractC -> CLabel -> AbstractC mkJoin code lbl | mightFallThrough code = mkAbsCStmts code (CJump (CLbl lbl PtrRep)) | otherwise = code diff --git a/ghc/compiler/nativeGen/AsmCodeGen.lhs b/ghc/compiler/nativeGen/AsmCodeGen.lhs index 22b95a57d5..95a18951bb 100644 --- a/ghc/compiler/nativeGen/AsmCodeGen.lhs +++ b/ghc/compiler/nativeGen/AsmCodeGen.lhs @@ -17,13 +17,14 @@ import PprMach import AbsCStixGen ( genCodeAbstractC ) import AbsCSyn ( AbstractC ) -import AbsCUtils ( mkAbsCStmtList ) +import AbsCUtils ( mkAbsCStmtList, magicIdPrimRep ) import AsmRegAlloc ( runRegAllocate ) -import PrimOp ( commutableOp, PrimOp(..) ) +import MachOp ( MachOp(..), isCommutableMachOp, isComparisonMachOp ) import RegAllocInfo ( findReservedRegs ) -import Stix ( StixTree(..), StixReg(..), - pprStixTrees, pprStixTree, - stixCountTempUses, stixSubst, +import Stix ( StixReg(..), StixStmt(..), StixExpr(..), StixVReg(..), + pprStixStmts, pprStixStmt, + stixStmt_CountTempUses, stixStmt_Subst, + liftStrings, initNat, mapNat, mkNatM_State, uniqOfNatM_State, deltaOfNatM_State ) @@ -95,12 +96,16 @@ nativeCodeGen absC us insn_sdoc = my_vcat insn_sdocs stix_sdoc = vcat stix_sdocs -# ifdef NCG_DEBUG +# ifdef NCG_DEBUG */ my_trace m x = trace m x - my_vcat sds = vcat (intersperse (char ' ' - $$ ptext SLIT("# ___ncg_debug_marker") - $$ char ' ') - sds) + my_vcat sds = Pretty.vcat ( + intersperse ( + Pretty.char ' ' + Pretty.$$ Pretty.ptext SLIT("# ___ncg_debug_marker") + Pretty.$$ Pretty.char ' ' + ) + sds + ) # else my_vcat sds = Pretty.vcat sds my_trace m x = x @@ -114,11 +119,12 @@ absCtoNat :: AbstractC -> UniqSM (SDoc, Pretty.Doc) absCtoNat absC = _scc_ "genCodeAbstractC" genCodeAbstractC absC `thenUs` \ stixRaw -> _scc_ "genericOpt" genericOpt stixRaw `bind` \ stixOpt -> - _scc_ "genMachCode" genMachCode stixOpt `thenUs` \ pre_regalloc -> + _scc_ "liftStrings" liftStrings stixOpt `thenUs` \ stixLifted -> + _scc_ "genMachCode" genMachCode stixLifted `thenUs` \ pre_regalloc -> _scc_ "regAlloc" regAlloc pre_regalloc `bind` \ almost_final -> _scc_ "x86fp_kludge" x86fp_kludge almost_final `bind` \ final_mach_code -> _scc_ "vcat" Pretty.vcat (map pprInstr final_mach_code) `bind` \ final_sdoc -> - _scc_ "pprStixTrees" pprStixTrees stixOpt `bind` \ stix_sdoc -> + _scc_ "pprStixTrees" pprStixStmts stixOpt `bind` \ stix_sdoc -> returnUs (stix_sdoc, final_sdoc) where bind f x = x f @@ -147,7 +153,7 @@ Switching between the two monads whilst carrying along the same Unique supply breaks abstraction. Is that bad? \begin{code} -genMachCode :: [StixTree] -> UniqSM InstrBlock +genMachCode :: [StixStmt] -> UniqSM InstrBlock genMachCode stmts initial_us = let initial_st = mkNatM_State initial_us 0 @@ -178,12 +184,12 @@ have introduced some new opportunities for constant-folding wrt address manipulations. \begin{code} -genericOpt :: [StixTree] -> [StixTree] -genericOpt = map stixConFold . stixPeep +genericOpt :: [StixStmt] -> [StixStmt] +genericOpt = map stixStmt_ConFold . stixPeep -stixPeep :: [StixTree] -> [StixTree] +stixPeep :: [StixStmt] -> [StixStmt] -- This transformation assumes that the temp assigned to in t1 -- is not assigned to in t2; for otherwise the target of the @@ -191,111 +197,120 @@ stixPeep :: [StixTree] -> [StixTree] -- code. As far as I can see, StixTemps are only ever assigned -- to once. It would be nice to be sure! -stixPeep ( t1@(StAssign pka (StReg (StixTemp u pk)) rhs) +stixPeep ( t1@(StAssignReg pka (StixTemp (StixVReg u pk)) rhs) : t2 : ts ) - | stixCountTempUses u t2 == 1 - && sum (map (stixCountTempUses u) ts) == 0 + | stixStmt_CountTempUses u t2 == 1 + && sum (map (stixStmt_CountTempUses u) ts) == 0 = # ifdef NCG_DEBUG - trace ("nativeGen: inlining " ++ showSDoc (pprStixTree rhs)) + trace ("nativeGen: inlining " ++ showSDoc (pprStixExpr rhs)) # endif - (stixPeep (stixSubst u rhs t2 : ts)) + (stixPeep (stixStmt_Subst u rhs t2 : ts)) stixPeep (t1:t2:ts) = t1 : stixPeep (t2:ts) stixPeep [t1] = [t1] stixPeep [] = [] - --- disable stix inlining until we figure out how to fix the --- latent bugs in the register allocator which are exposed by --- the inliner. ---stixPeep = id \end{code} For most nodes, just optimize the children. \begin{code} -stixConFold :: StixTree -> StixTree - -stixConFold (StInd pk addr) = StInd pk (stixConFold addr) - -stixConFold (StAssign pk dst src) - = StAssign pk (stixConFold dst) (stixConFold src) - -stixConFold (StJump dsts addr) = StJump dsts (stixConFold addr) - -stixConFold (StCondJump addr test) - = StCondJump addr (stixConFold test) - -stixConFold (StCall fn cconv pk args) - = StCall fn cconv pk (map stixConFold args) -\end{code} - -Fold indices together when the types match: -\begin{code} -stixConFold (StIndex pk (StIndex pk' base off) off') - | pk == pk' - = StIndex pk (stixConFold base) - (stixConFold (StPrim IntAddOp [off, off'])) - -stixConFold (StIndex pk base off) - = StIndex pk (stixConFold base) (stixConFold off) -\end{code} - -For PrimOps, we first optimize the children, and then we try our hand -at some constant-folding. - -\begin{code} -stixConFold (StPrim op args) = stixPrimFold op (map stixConFold args) -\end{code} - -Replace register leaves with appropriate StixTrees for the given -target. - -\begin{code} -stixConFold leaf@(StReg (StixMagicId id)) - = case (stgReg id) of - Always tree -> stixConFold tree - Save _ -> leaf - -stixConFold other = other +stixExpr_ConFold :: StixExpr -> StixExpr +stixStmt_ConFold :: StixStmt -> StixStmt + +stixStmt_ConFold stmt + = case stmt of + StAssignReg pk reg@(StixTemp _) src + -> StAssignReg pk reg (stixExpr_ConFold src) + StAssignReg pk reg@(StixMagicId mid) src + -- Replace register leaves with appropriate StixTrees for + -- the given target. + -> case get_MagicId_reg_or_addr mid of + Left realreg + -> StAssignReg pk reg (stixExpr_ConFold src) + Right baseRegAddr + -> stixStmt_ConFold + (StAssignMem pk baseRegAddr src) + StAssignMem pk addr src + -> StAssignMem pk (stixExpr_ConFold addr) (stixExpr_ConFold src) + StAssignMachOp lhss mop args + -> StAssignMachOp lhss mop (map stixExpr_ConFold args) + StVoidable expr + -> StVoidable (stixExpr_ConFold expr) + StJump dsts addr + -> StJump dsts (stixExpr_ConFold addr) + StCondJump addr test + -> StCondJump addr (stixExpr_ConFold test) + StData pk datas + -> StData pk (map stixExpr_ConFold datas) + other + -> other + + +stixExpr_ConFold expr + = case expr of + StInd pk addr + -> StInd pk (stixExpr_ConFold addr) + StCall fn cconv pk args + -> StCall fn cconv pk (map stixExpr_ConFold args) + StIndex pk (StIndex pk' base off) off' + -- Fold indices together when the types match: + | pk == pk' + -> StIndex pk (stixExpr_ConFold base) + (stixExpr_ConFold (StMachOp MO_Nat_Add [off, off'])) + StIndex pk base off + -> StIndex pk (stixExpr_ConFold base) (stixExpr_ConFold off) + + StMachOp mop args + -- For PrimOps, we first optimize the children, and then we try + -- our hand at some constant-folding. + -> stixMachOpFold mop (map stixExpr_ConFold args) + StReg (StixMagicId mid) + -- Replace register leaves with appropriate StixTrees for + -- the given target. + -> case get_MagicId_reg_or_addr mid of + Left realreg -> expr + Right baseRegAddr + -> stixExpr_ConFold (StInd (magicIdPrimRep mid) baseRegAddr) + other + -> other \end{code} Now, try to constant-fold the PrimOps. The arguments have already been optimized and folded. \begin{code} -stixPrimFold - :: PrimOp -- The operation from an StPrim - -> [StixTree] -- The optimized arguments - -> StixTree - -stixPrimFold op arg@[StInt x] - = case op of - IntNegOp -> StInt (-x) - _ -> StPrim op arg - -stixPrimFold op args@[StInt x, StInt y] - = case op of - CharGtOp -> StInt (if x > y then 1 else 0) - CharGeOp -> StInt (if x >= y then 1 else 0) - CharEqOp -> StInt (if x == y then 1 else 0) - CharNeOp -> StInt (if x /= y then 1 else 0) - CharLtOp -> StInt (if x < y then 1 else 0) - CharLeOp -> StInt (if x <= y then 1 else 0) - IntAddOp -> StInt (x + y) - IntSubOp -> StInt (x - y) - IntMulOp -> StInt (x * y) - IntQuotOp -> StInt (x `quot` y) - IntRemOp -> StInt (x `rem` y) - IntGtOp -> StInt (if x > y then 1 else 0) - IntGeOp -> StInt (if x >= y then 1 else 0) - IntEqOp -> StInt (if x == y then 1 else 0) - IntNeOp -> StInt (if x /= y then 1 else 0) - IntLtOp -> StInt (if x < y then 1 else 0) - IntLeOp -> StInt (if x <= y then 1 else 0) - -- ToDo: WordQuotOp, WordRemOp. - _ -> StPrim op args +stixMachOpFold + :: MachOp -- The operation from an StMachOp + -> [StixExpr] -- The optimized arguments + -> StixExpr + +stixMachOpFold mop arg@[StInt x] + = case mop of + MO_NatS_Neg -> StInt (-x) + other -> StMachOp mop arg + +stixMachOpFold mop args@[StInt x, StInt y] + = case mop of + MO_32U_Gt -> StInt (if x > y then 1 else 0) + MO_32U_Ge -> StInt (if x >= y then 1 else 0) + MO_32U_Eq -> StInt (if x == y then 1 else 0) + MO_32U_Ne -> StInt (if x /= y then 1 else 0) + MO_32U_Lt -> StInt (if x < y then 1 else 0) + MO_32U_Le -> StInt (if x <= y then 1 else 0) + MO_Nat_Add -> StInt (x + y) + MO_Nat_Sub -> StInt (x - y) + MO_NatS_Mul -> StInt (x * y) + MO_NatS_Quot | y /= 0 -> StInt (x `quot` y) + MO_NatS_Rem | y /= 0 -> StInt (x `rem` y) + MO_NatS_Gt -> StInt (if x > y then 1 else 0) + MO_NatS_Ge -> StInt (if x >= y then 1 else 0) + MO_Nat_Eq -> StInt (if x == y then 1 else 0) + MO_Nat_Ne -> StInt (if x /= y then 1 else 0) + MO_NatS_Lt -> StInt (if x < y then 1 else 0) + MO_NatS_Le -> StInt (if x <= y then 1 else 0) + other -> StMachOp mop args \end{code} When possible, shift the constants to the right-hand side, so that we @@ -304,68 +319,65 @@ also assume that constants have been shifted to the right when possible. \begin{code} -stixPrimFold op [x@(StInt _), y] | commutableOp op = stixPrimFold op [y, x] +stixMachOpFold op [x@(StInt _), y] | isCommutableMachOp op + = stixMachOpFold op [y, x] \end{code} We can often do something with constants of 0 and 1 ... \begin{code} -stixPrimFold op args@[x, y@(StInt 0)] - = case op of - IntAddOp -> x - IntSubOp -> x - IntMulOp -> y - AndOp -> y - OrOp -> x - XorOp -> x - SllOp -> x - SrlOp -> x - ISllOp -> x - ISraOp -> x - ISrlOp -> x - IntNeOp | is_comparison -> x - _ -> StPrim op args +stixMachOpFold mop args@[x, y@(StInt 0)] + = case mop of + MO_Nat_Add -> x + MO_Nat_Sub -> x + MO_NatS_Mul -> y + MO_NatU_Mul -> y + MO_Nat_And -> y + MO_Nat_Or -> x + MO_Nat_Xor -> x + MO_Nat_Shl -> x + MO_Nat_Shr -> x + MO_Nat_Sar -> x + MO_Nat_Ne | x_is_comparison -> x + other -> StMachOp mop args where - is_comparison + x_is_comparison = case x of - StPrim opp [_, _] -> opp `elem` comparison_ops - _ -> False - -stixPrimFold op args@[x, y@(StInt 1)] - = case op of - IntMulOp -> x - IntQuotOp -> x - IntRemOp -> StInt 0 - _ -> StPrim op args + StMachOp mopp [_, _] -> isComparisonMachOp mopp + _ -> False + +stixMachOpFold mop args@[x, y@(StInt 1)] + = case mop of + MO_NatS_Mul -> x + MO_NatU_Mul -> x + MO_NatS_Quot -> x + MO_NatU_Quot -> x + MO_NatS_Rem -> StInt 0 + MO_NatU_Rem -> StInt 0 + other -> StMachOp mop args \end{code} Now look for multiplication/division by powers of 2 (integers). \begin{code} -stixPrimFold op args@[x, y@(StInt n)] - = case op of - IntMulOp -> case exactLog2 n of - Nothing -> StPrim op args - Just p -> StPrim ISllOp [x, StInt p] - IntQuotOp -> case exactLog2 n of - Nothing -> StPrim op args - Just p -> StPrim ISrlOp [x, StInt p] - _ -> StPrim op args +stixMachOpFold mop args@[x, y@(StInt n)] + = case mop of + MO_NatS_Mul + -> case exactLog2 n of + Nothing -> unchanged + Just p -> StMachOp MO_Nat_Shl [x, StInt p] + MO_NatS_Quot + -> case exactLog2 n of + Nothing -> unchanged + Just p -> StMachOp MO_Nat_Shr [x, StInt p] + other + -> unchanged + where + unchanged = StMachOp mop args \end{code} Anything else is just too hard. \begin{code} -stixPrimFold op args = StPrim op args -\end{code} - -\begin{code} -comparison_ops - = [ CharGtOp , CharGeOp , CharEqOp , CharNeOp , CharLtOp , CharLeOp, - IntGtOp , IntGeOp , IntEqOp , IntNeOp , IntLtOp , IntLeOp, - WordGtOp , WordGeOp , WordEqOp , WordNeOp , WordLtOp , WordLeOp, - AddrGtOp , AddrGeOp , AddrEqOp , AddrNeOp , AddrLtOp , AddrLeOp, - FloatGtOp , FloatGeOp , FloatEqOp , FloatNeOp , FloatLtOp , FloatLeOp, - DoubleGtOp, DoubleGeOp, DoubleEqOp, DoubleNeOp, DoubleLtOp, DoubleLeOp - ] +stixMachOpFold mop args = StMachOp mop args \end{code} diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs index b2a4e8239f..35c86b795c 100644 --- a/ghc/compiler/nativeGen/MachCode.lhs +++ b/ghc/compiler/nativeGen/MachCode.lhs @@ -18,29 +18,35 @@ import MachMisc -- may differ per-platform import MachRegs import OrdList ( OrdList, nilOL, isNilOL, unitOL, appOL, toOL, snocOL, consOL, concatOL ) +import MachOp ( MachOp(..), pprMachOp ) import AbsCUtils ( magicIdPrimRep ) +import PprAbsC ( pprMagicId ) import ForeignCall ( CCallConv(..) ) import CLabel ( CLabel, labelDynamic ) #if sparc_TARGET_ARCH || alpha_TARGET_ARCH import CLabel ( isAsmTemp ) #endif -import Maybes ( maybeToBool ) +import Maybes ( maybeToBool, Maybe012(..) ) import PrimRep ( isFloatingRep, PrimRep(..) ) -import PrimOp ( PrimOp(..) ) -import Stix ( getNatLabelNCG, StixTree(..), - StixReg(..), CodeSegment(..), +import Stix ( getNatLabelNCG, StixStmt(..), StixExpr(..), + StixReg(..), StixVReg(..), CodeSegment(..), DestInfo, hasDestInfo, - pprStixTree, + pprStixExpr, + liftStrings, NatM, thenNat, returnNat, mapNat, mapAndUnzipNat, mapAccumLNat, getDeltaNat, setDeltaNat, ncgPrimopMoan ) import Pretty -import Outputable ( panic, pprPanic ) +import Outputable ( panic, pprPanic, showSDoc ) import qualified Outputable import CmdLineOpts ( opt_Static ) +-- DEBUGGING ONLY +import IOExts ( trace ) +import Stix ( pprStixStmt ) + infixr 3 `bind` \end{code} @@ -58,84 +64,13 @@ x `bind` f = f x Code extractor for an entire stix tree---stix statement level. \begin{code} -stmtsToInstrs :: [StixTree] -> NatM InstrBlock +stmtsToInstrs :: [StixStmt] -> NatM InstrBlock stmtsToInstrs stmts - = liftStrings stmts [] [] `thenNat` \ lifted -> - mapNat stmtToInstrs lifted `thenNat` \ instrss -> + = mapNat stmtToInstrs stmts `thenNat` \ instrss -> returnNat (concatOL instrss) --- Lift StStrings out of top-level StDatas, putting them at the end of --- the block, and replacing them with StCLbls which refer to the lifted-out strings. -{- Motivation for this hackery provided by the following bug: - Stix: - (DataSegment) - Bogon.ping_closure : - (Data P_ Addr.A#_static_info) - (Data StgAddr (Str `alalal')) - (Data P_ (0)) - results in: - .data - .align 8 - .global Bogon_ping_closure - Bogon_ping_closure: - .long Addr_Azh_static_info - .long .Ln1a8 - .Ln1a8: - .byte 0x61 - .byte 0x6C - .byte 0x61 - .byte 0x6C - .byte 0x61 - .byte 0x6C - .byte 0x00 - .long 0 - ie, the Str is planted in-line, when what we really meant was to place - a _reference_ to the string there. liftStrings will lift out all such - strings in top-level data and place them at the end of the block. - - This is still a rather half-baked solution -- to do the job entirely right - would mean a complete traversal of all the Stixes, but there's currently no - real need for it, and it would be slow. Also, potentially there could be - literal types other than strings which need lifting out? --} - -liftStrings :: [StixTree] -- originals - -> [StixTree] -- (reverse) originals with strings lifted out - -> [(CLabel, FAST_STRING)] -- lifted strs, and their new labels - -> NatM [StixTree] - --- First, examine the original trees and lift out strings in top-level StDatas. -liftStrings (st:sts) acc_stix acc_strs - = case st of - StData sz datas - -> lift datas acc_strs `thenNat` \ (datas_done, acc_strs1) -> - liftStrings sts ((StData sz datas_done):acc_stix) acc_strs1 - other - -> liftStrings sts (other:acc_stix) acc_strs - where - -- Handle a top-level StData - lift [] acc_strs = returnNat ([], acc_strs) - lift (d:ds) acc_strs - = lift ds acc_strs `thenNat` \ (ds_done, acc_strs1) -> - case d of - StString s - -> getNatLabelNCG `thenNat` \ lbl -> - returnNat ((StCLbl lbl):ds_done, ((lbl,s):acc_strs1)) - other - -> returnNat (other:ds_done, acc_strs1) - --- When we've run out of original trees, emit the lifted strings. -liftStrings [] acc_stix acc_strs - = returnNat (reverse acc_stix ++ concatMap f acc_strs) - where - f (lbl,str) = [StSegment RoDataSegment, - StLabel lbl, - StString str, - StSegment TextSegment] - - -stmtToInstrs :: StixTree {- a stix statement -} -> NatM InstrBlock +stmtToInstrs :: StixStmt -> NatM InstrBlock stmtToInstrs stmt = case stmt of StComment s -> returnNat (unitOL (COMMENT s)) StSegment seg -> returnNat (unitOL (SEGMENT seg)) @@ -150,13 +85,19 @@ stmtToInstrs stmt = case stmt of StJump dsts arg -> genJump dsts (derefDLL arg) StCondJump lab arg -> genCondJump lab (derefDLL arg) - -- A call returning void, ie one done for its side-effects - StCall fn cconv VoidRep args -> genCCall fn - cconv VoidRep (map derefDLL args) + -- A call returning void, ie one done for its side-effects. Note + -- that this is the only StVoidable we handle. + StVoidable (StCall fn cconv VoidRep args) + -> genCCall fn cconv VoidRep (map derefDLL args) - StAssign pk dst src - | isFloatingRep pk -> assignFltCode pk (derefDLL dst) (derefDLL src) - | otherwise -> assignIntCode pk (derefDLL dst) (derefDLL src) + StAssignMem pk addr src + | isFloatingRep pk -> assignMem_FltCode pk (derefDLL addr) (derefDLL src) + | otherwise -> assignMem_IntCode pk (derefDLL addr) (derefDLL src) + StAssignReg pk reg src + | isFloatingRep pk -> assignReg_FltCode pk reg (derefDLL src) + | otherwise -> assignReg_IntCode pk reg (derefDLL src) + StAssignMachOp lhss mop rhss + -> assignMachOp lhss mop rhss StFallThrough lbl -- When falling through on the Alpha, we still have to load pv @@ -169,7 +110,7 @@ stmtToInstrs stmt = case stmt of returnNat (DATA (primRepToSize kind) imms `consOL` concatOL codes) where - getData :: StixTree -> NatM (InstrBlock, Imm) + getData :: StixExpr -> NatM (InstrBlock, Imm) getData (StInt i) = returnNat (nilOL, ImmInteger i) getData (StDouble d) = returnNat (nilOL, ImmDouble d) getData (StFloat d) = returnNat (nilOL, ImmFloat d) @@ -181,8 +122,8 @@ stmtToInstrs stmt = case stmt of ImmIndex lbl (fromInteger off * sizeOf rep)) -- Top-level lifted-out string. The segment will already have been set - -- (see liftStrings above). - StString str + -- (see Stix.liftStrings). + StDataString str -> returnNat (unitOL (ASCII True (_UNPK_ str))) #ifdef DEBUG @@ -193,7 +134,7 @@ stmtToInstrs stmt = case stmt of -- as labelDynamic. stmt2Instrs calls derefDLL selectively, because -- not all such CLabel occurrences need this dereferencing -- SRTs don't -- for one. -derefDLL :: StixTree -> StixTree +derefDLL :: StixExpr -> StixExpr derefDLL tree | opt_Static -- short out the entire deal if not doing DLLs = tree @@ -207,7 +148,7 @@ derefDLL tree else t -- all the rest are boring StIndex pk base offset -> StIndex pk (qq base) (qq offset) - StPrim pk args -> StPrim pk (map qq args) + StMachOp mop args -> StMachOp mop (map qq args) StInd pk addr -> StInd pk (qq addr) StCall who cc pk args -> StCall who cc pk (map qq args) StInt _ -> t @@ -215,9 +156,8 @@ derefDLL tree StDouble _ -> t StString _ -> t StReg _ -> t - StScratchWord _ -> t _ -> pprPanic "derefDLL: unhandled case" - (pprStixTree t) + (pprStixExpr t) \end{code} %************************************************************************ @@ -227,19 +167,19 @@ derefDLL tree %************************************************************************ \begin{code} -mangleIndexTree :: StixTree -> StixTree +mangleIndexTree :: StixExpr -> StixExpr mangleIndexTree (StIndex pk base (StInt i)) - = StPrim IntAddOp [base, off] + = StMachOp MO_Nat_Add [base, off] where off = StInt (i * toInteger (sizeOf pk)) mangleIndexTree (StIndex pk base off) - = StPrim IntAddOp [ + = StMachOp MO_Nat_Add [ base, let s = shift pk - in if s == 0 then off else StPrim SllOp [off, StInt (toInteger s)] - ] + in if s == 0 then off else StMachOp MO_Nat_Shl [off, StInt (toInteger s)] + ] where shift :: PrimRep -> Int shift rep = case sizeOf rep of @@ -252,7 +192,7 @@ mangleIndexTree (StIndex pk base off) \end{code} \begin{code} -maybeImm :: StixTree -> Maybe Imm +maybeImm :: StixExpr -> Maybe Imm maybeImm (StCLbl l) = Just (ImmCLbl l) @@ -304,6 +244,10 @@ registerRep :: Register -> PrimRep registerRep (Fixed pk _ _) = pk registerRep (Any pk _) = pk +swizzleRegisterRep :: Register -> PrimRep -> Register +swizzleRegisterRep (Fixed _ reg code) rep = Fixed rep reg code +swizzleRegisterRep (Any _ codefn) rep = Any rep codefn + {-# INLINE registerCode #-} {-# INLINE registerCodeF #-} {-# INLINE registerName #-} @@ -321,17 +265,31 @@ isAny = not . isFixed Generate code to get a subtree into a @Register@: \begin{code} -getRegister :: StixTree -> NatM Register -getRegister (StReg (StixMagicId stgreg)) - = case (magicIdRegMaybe stgreg) of - Just reg -> returnNat (Fixed (magicIdPrimRep stgreg) reg nilOL) - -- cannae be Nothing +getRegisterReg :: StixReg -> NatM Register -getRegister (StReg (StixTemp u pk)) +getRegisterReg (StixMagicId mid) + = case get_MagicId_reg_or_addr mid of + Left (RealReg rrno) + -> let pk = magicIdPrimRep mid + in returnNat (Fixed pk (RealReg rrno) nilOL) + Right baseRegAddr + -- By this stage, the only MagicIds remaining should be the + -- ones which map to a real machine register on this platform. Hence ... + -> pprPanic "getRegisterReg-memory" (pprMagicId mid) + +getRegisterReg (StixTemp (StixVReg u pk)) = returnNat (Fixed pk (mkVReg u pk) nilOL) -getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree) +------------- + +getRegister :: StixExpr -> NatM Register + +getRegister (StReg reg) + = getRegisterReg reg + +getRegister tree@(StIndex _ _ _) + = getRegister (mangleIndexTree tree) getRegister (StCall fn cconv kind args) = genCCall fn cconv kind args `thenNat` \ call -> @@ -638,176 +596,180 @@ getRegister (StDouble d) in returnNat (Any DoubleRep code) --- Calculate the offset for (i+1) words above the _initial_ --- %esp value by first determining the current offset of it. -getRegister (StScratchWord i) - | i >= 0 && i < 6 - = getDeltaNat `thenNat` \ current_stack_offset -> - let j = i+1 - (current_stack_offset `div` 4) - code dst - = unitOL (LEA L (OpAddr (spRel j)) (OpReg dst)) - in - returnNat (Any PtrRep code) -getRegister (StPrim primop [x]) -- unary PrimOps - = case primop of - IntNegOp -> trivialUCode (NEGI L) x - NotOp -> trivialUCode (NOT L) x +getRegister (StMachOp mop [x]) -- unary MachOps + = case mop of + MO_NatS_Neg -> trivialUCode (NEGI L) x + MO_Nat_Not -> trivialUCode (NOT L) x - FloatNegOp -> trivialUFCode FloatRep (GNEG F) x - DoubleNegOp -> trivialUFCode DoubleRep (GNEG DF) x + MO_Flt_Neg -> trivialUFCode FloatRep (GNEG F) x + MO_Dbl_Neg -> trivialUFCode DoubleRep (GNEG DF) x - FloatSqrtOp -> trivialUFCode FloatRep (GSQRT F) x - DoubleSqrtOp -> trivialUFCode DoubleRep (GSQRT DF) x + MO_Flt_Sqrt -> trivialUFCode FloatRep (GSQRT F) x + MO_Dbl_Sqrt -> trivialUFCode DoubleRep (GSQRT DF) x - FloatSinOp -> trivialUFCode FloatRep (GSIN F) x - DoubleSinOp -> trivialUFCode DoubleRep (GSIN DF) x + MO_Flt_Sin -> trivialUFCode FloatRep (GSIN F) x + MO_Dbl_Sin -> trivialUFCode DoubleRep (GSIN DF) x - FloatCosOp -> trivialUFCode FloatRep (GCOS F) x - DoubleCosOp -> trivialUFCode DoubleRep (GCOS DF) x + MO_Flt_Cos -> trivialUFCode FloatRep (GCOS F) x + MO_Dbl_Cos -> trivialUFCode DoubleRep (GCOS DF) x - FloatTanOp -> trivialUFCode FloatRep (GTAN F) x - DoubleTanOp -> trivialUFCode DoubleRep (GTAN DF) x + MO_Flt_Tan -> trivialUFCode FloatRep (GTAN F) x + MO_Dbl_Tan -> trivialUFCode DoubleRep (GTAN DF) x - Double2FloatOp -> trivialUFCode FloatRep GDTOF x - Float2DoubleOp -> trivialUFCode DoubleRep GFTOD x + MO_Flt_to_NatS -> coerceFP2Int x + MO_NatS_to_Flt -> coerceInt2FP FloatRep x + MO_Dbl_to_NatS -> coerceFP2Int x + MO_NatS_to_Dbl -> coerceInt2FP DoubleRep x - OrdOp -> coerceIntCode IntRep x - ChrOp -> chrCode x + -- Conversions which are a nop on x86 + MO_NatS_to_32U -> conversionNop WordRep x + MO_32U_to_NatS -> conversionNop IntRep x - Float2IntOp -> coerceFP2Int x - Int2FloatOp -> coerceInt2FP FloatRep x - Double2IntOp -> coerceFP2Int x - Int2DoubleOp -> coerceInt2FP DoubleRep x + MO_NatU_to_NatS -> conversionNop IntRep x + MO_NatS_to_NatU -> conversionNop WordRep x + MO_NatP_to_NatU -> conversionNop WordRep x + MO_NatU_to_NatP -> conversionNop PtrRep x + MO_NatS_to_NatP -> conversionNop PtrRep x + MO_NatP_to_NatS -> conversionNop IntRep x - other_op -> - getRegister (StCall fn CCallConv DoubleRep [x]) - where - (is_float_op, fn) - = case primop of - FloatExpOp -> (True, SLIT("exp")) - FloatLogOp -> (True, SLIT("log")) + MO_Dbl_to_Flt -> conversionNop FloatRep x + MO_Flt_to_Dbl -> conversionNop DoubleRep x - FloatAsinOp -> (True, SLIT("asin")) - FloatAcosOp -> (True, SLIT("acos")) - FloatAtanOp -> (True, SLIT("atan")) + MO_8U_to_NatU -> integerExtend False 24 x + MO_8S_to_NatS -> integerExtend True 24 x + MO_16U_to_NatU -> integerExtend False 16 x + MO_16S_to_NatS -> integerExtend True 16 x - FloatSinhOp -> (True, SLIT("sinh")) - FloatCoshOp -> (True, SLIT("cosh")) - FloatTanhOp -> (True, SLIT("tanh")) - - DoubleExpOp -> (False, SLIT("exp")) - DoubleLogOp -> (False, SLIT("log")) - - DoubleAsinOp -> (False, SLIT("asin")) - DoubleAcosOp -> (False, SLIT("acos")) - DoubleAtanOp -> (False, SLIT("atan")) - - DoubleSinhOp -> (False, SLIT("sinh")) - DoubleCoshOp -> (False, SLIT("cosh")) - DoubleTanhOp -> (False, SLIT("tanh")) - - other - -> ncgPrimopMoan "getRegister(x86,unary primop)" - (pprStixTree (StPrim primop [x])) - -getRegister (StPrim primop [x, y]) -- dyadic PrimOps - = case primop of - CharGtOp -> condIntReg GTT x y - CharGeOp -> condIntReg GE x y - CharEqOp -> condIntReg EQQ x y - CharNeOp -> condIntReg NE x y - CharLtOp -> condIntReg LTT x y - CharLeOp -> condIntReg LE x y - - IntGtOp -> condIntReg GTT x y - IntGeOp -> condIntReg GE x y - IntEqOp -> condIntReg EQQ x y - IntNeOp -> condIntReg NE x y - IntLtOp -> condIntReg LTT x y - IntLeOp -> condIntReg LE x y - - WordGtOp -> condIntReg GU x y - WordGeOp -> condIntReg GEU x y - WordEqOp -> condIntReg EQQ x y - WordNeOp -> condIntReg NE x y - WordLtOp -> condIntReg LU x y - WordLeOp -> condIntReg LEU x y - - AddrGtOp -> condIntReg GU x y - AddrGeOp -> condIntReg GEU x y - AddrEqOp -> condIntReg EQQ x y - AddrNeOp -> condIntReg NE x y - AddrLtOp -> condIntReg LU x y - AddrLeOp -> condIntReg LEU x y - - FloatGtOp -> condFltReg GTT x y - FloatGeOp -> condFltReg GE x y - FloatEqOp -> condFltReg EQQ x y - FloatNeOp -> condFltReg NE x y - FloatLtOp -> condFltReg LTT x y - FloatLeOp -> condFltReg LE x y - - DoubleGtOp -> condFltReg GTT x y - DoubleGeOp -> condFltReg GE x y - DoubleEqOp -> condFltReg EQQ x y - DoubleNeOp -> condFltReg NE x y - DoubleLtOp -> condFltReg LTT x y - DoubleLeOp -> condFltReg LE x y - - IntAddOp -> add_code L x y - IntSubOp -> sub_code L x y - IntQuotOp -> trivialCode (IQUOT L) Nothing x y - IntRemOp -> trivialCode (IREM L) Nothing x y - IntMulOp -> let op = IMUL L in trivialCode op (Just op) x y - - WordAddOp -> add_code L x y - WordSubOp -> sub_code L x y - WordMulOp -> let op = IMUL L in trivialCode op (Just op) x y - - FloatAddOp -> trivialFCode FloatRep GADD x y - FloatSubOp -> trivialFCode FloatRep GSUB x y - FloatMulOp -> trivialFCode FloatRep GMUL x y - FloatDivOp -> trivialFCode FloatRep GDIV x y - - DoubleAddOp -> trivialFCode DoubleRep GADD x y - DoubleSubOp -> trivialFCode DoubleRep GSUB x y - DoubleMulOp -> trivialFCode DoubleRep GMUL x y - DoubleDivOp -> trivialFCode DoubleRep GDIV x y - - AddrAddOp -> add_code L x y - AddrSubOp -> sub_code L x y - AddrRemOp -> trivialCode (IREM L) Nothing x y - - AndOp -> let op = AND L in trivialCode op (Just op) x y - OrOp -> let op = OR L in trivialCode op (Just op) x y - XorOp -> let op = XOR L in trivialCode op (Just op) x y + other_op + -> getRegister ( + (if is_float_op then demote else id) + (StCall fn CCallConv DoubleRep + [(if is_float_op then promote else id) x]) + ) + where + integerExtend signed nBits x + = getRegister ( + StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr) + [StInt nBits, StMachOp MO_Nat_Shl [StInt nBits, x]] + ) + + conversionNop new_rep expr + = getRegister expr `thenNat` \ e_code -> + returnNat (swizzleRegisterRep e_code new_rep) + + promote x = StMachOp MO_Flt_to_Dbl [x] + demote x = StMachOp MO_Dbl_to_Flt [x] + (is_float_op, fn) + = case mop of + MO_Flt_Exp -> (True, SLIT("exp")) + MO_Flt_Log -> (True, SLIT("log")) + + MO_Flt_Asin -> (True, SLIT("asin")) + MO_Flt_Acos -> (True, SLIT("acos")) + MO_Flt_Atan -> (True, SLIT("atan")) + + MO_Flt_Sinh -> (True, SLIT("sinh")) + MO_Flt_Cosh -> (True, SLIT("cosh")) + MO_Flt_Tanh -> (True, SLIT("tanh")) + + MO_Dbl_Exp -> (False, SLIT("exp")) + MO_Dbl_Log -> (False, SLIT("log")) + + MO_Dbl_Asin -> (False, SLIT("asin")) + MO_Dbl_Acos -> (False, SLIT("acos")) + MO_Dbl_Atan -> (False, SLIT("atan")) + + MO_Dbl_Sinh -> (False, SLIT("sinh")) + MO_Dbl_Cosh -> (False, SLIT("cosh")) + MO_Dbl_Tanh -> (False, SLIT("tanh")) + + other -> pprPanic "getRegister(x86) - binary StMachOp (2)" + (pprMachOp mop) + + +getRegister (StMachOp mop [x, y]) -- dyadic MachOps + = case mop of + MO_32U_Gt -> condIntReg GTT x y + MO_32U_Ge -> condIntReg GE x y + MO_32U_Eq -> condIntReg EQQ x y + MO_32U_Ne -> condIntReg NE x y + MO_32U_Lt -> condIntReg LTT x y + MO_32U_Le -> condIntReg LE x y + + MO_Nat_Eq -> condIntReg EQQ x y + MO_Nat_Ne -> condIntReg NE x y + + MO_NatS_Gt -> condIntReg GTT x y + MO_NatS_Ge -> condIntReg GE x y + MO_NatS_Lt -> condIntReg LTT x y + MO_NatS_Le -> condIntReg LE x y + + MO_NatU_Gt -> condIntReg GU x y + MO_NatU_Ge -> condIntReg GEU x y + MO_NatU_Lt -> condIntReg LU x y + MO_NatU_Le -> condIntReg LEU x y + + MO_Flt_Gt -> condFltReg GTT x y + MO_Flt_Ge -> condFltReg GE x y + MO_Flt_Eq -> condFltReg EQQ x y + MO_Flt_Ne -> condFltReg NE x y + MO_Flt_Lt -> condFltReg LTT x y + MO_Flt_Le -> condFltReg LE x y + + MO_Dbl_Gt -> condFltReg GTT x y + MO_Dbl_Ge -> condFltReg GE x y + MO_Dbl_Eq -> condFltReg EQQ x y + MO_Dbl_Ne -> condFltReg NE x y + MO_Dbl_Lt -> condFltReg LTT x y + MO_Dbl_Le -> condFltReg LE x y + + MO_Nat_Add -> add_code L x y + MO_Nat_Sub -> sub_code L x y + MO_NatS_Quot -> trivialCode (IQUOT L) Nothing x y + MO_NatS_Rem -> trivialCode (IREM L) Nothing x y + MO_NatU_Quot -> trivialCode (QUOT L) Nothing x y + MO_NatU_Rem -> trivialCode (REM L) Nothing x y + MO_NatS_Mul -> let op = IMUL L in trivialCode op (Just op) x y + MO_NatU_Mul -> let op = MUL L in trivialCode op (Just op) x y + + MO_Flt_Add -> trivialFCode FloatRep GADD x y + MO_Flt_Sub -> trivialFCode FloatRep GSUB x y + MO_Flt_Mul -> trivialFCode FloatRep GMUL x y + MO_Flt_Div -> trivialFCode FloatRep GDIV x y + + MO_Dbl_Add -> trivialFCode DoubleRep GADD x y + MO_Dbl_Sub -> trivialFCode DoubleRep GSUB x y + MO_Dbl_Mul -> trivialFCode DoubleRep GMUL x y + MO_Dbl_Div -> trivialFCode DoubleRep GDIV x y + + MO_Nat_And -> let op = AND L in trivialCode op (Just op) x y + MO_Nat_Or -> let op = OR L in trivialCode op (Just op) x y + MO_Nat_Xor -> let op = XOR L in trivialCode op (Just op) x y {- Shift ops on x86s have constraints on their source, it either has to be Imm, CL or 1 => trivialCode's is not restrictive enough (sigh.) - -} - - SllOp -> shift_code (SHL L) x y {-False-} - SrlOp -> shift_code (SHR L) x y {-False-} - ISllOp -> shift_code (SHL L) x y {-False-} - ISraOp -> shift_code (SAR L) x y {-False-} - ISrlOp -> shift_code (SHR L) x y {-False-} + -} + MO_Nat_Shl -> shift_code (SHL L) x y {-False-} + MO_Nat_Shr -> shift_code (SHR L) x y {-False-} + MO_Nat_Sar -> shift_code (SAR L) x y {-False-} - FloatPowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep + MO_Flt_Pwr -> getRegister (demote + (StCall SLIT("pow") CCallConv DoubleRep [promote x, promote y]) - where promote x = StPrim Float2DoubleOp [x] - DoublePowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep + ) + MO_Dbl_Pwr -> getRegister (StCall SLIT("pow") CCallConv DoubleRep [x, y]) - other - -> ncgPrimopMoan "getRegister(x86,dyadic primop)" - (pprStixTree (StPrim primop [x, y])) + other -> pprPanic "getRegister(x86) - binary StMachOp (1)" (pprMachOp mop) where + promote x = StMachOp MO_Flt_to_Dbl [x] + demote x = StMachOp MO_Dbl_to_Flt [x] -------------------- shift_code :: (Imm -> Operand -> Instr) - -> StixTree - -> StixTree + -> StixExpr + -> StixExpr -> NatM Register {- Case1: shift length as immediate -} @@ -895,7 +857,7 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps returnNat (Any IntRep code__2) -------------------- - add_code :: Size -> StixTree -> StixTree -> NatM Register + add_code :: Size -> StixExpr -> StixExpr -> NatM Register add_code sz x (StInt y) = getRegister x `thenNat` \ register -> @@ -914,7 +876,7 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps add_code sz x y = trivialCode (ADD sz) (Just (ADD sz)) x y -------------------- - sub_code :: Size -> StixTree -> StixTree -> NatM Register + sub_code :: Size -> StixExpr -> StixExpr -> NatM Register sub_code sz x (StInt y) = getRegister x `thenNat` \ register -> @@ -932,7 +894,6 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps sub_code sz x y = trivialCode (SUB sz) Nothing x y - getRegister (StInd pk mem) = getAmode mem `thenNat` \ amode -> let @@ -970,11 +931,49 @@ getRegister leaf in returnNat (Any PtrRep code) | otherwise - = ncgPrimopMoan "getRegister(x86)" (pprStixTree leaf) + = ncgPrimopMoan "getRegister(x86)" (pprStixExpr leaf) where imm = maybeImm leaf imm__2 = case imm of Just x -> x + +assignMachOp :: Maybe012 StixVReg -> MachOp -> [StixExpr] + -> NatM InstrBlock + +assignMachOp (Just2 sv_rr sv_cc) mop [aa,bb] + | mop `elem` [MO_NatS_AddC, MO_NatS_SubC, MO_NatS_MulC] + = getRegister aa `thenNat` \ registeraa -> + getRegister bb `thenNat` \ registerbb -> + getNewRegNCG IntRep `thenNat` \ tmp -> + getNewRegNCG IntRep `thenNat` \ tmpaa -> + getNewRegNCG IntRep `thenNat` \ tmpbb -> + let stixVReg_to_VReg (StixVReg u rep) = mkVReg u rep + rr = stixVReg_to_VReg sv_rr + cc = stixVReg_to_VReg sv_cc + codeaa = registerCode registeraa tmpaa + srcaa = registerName registeraa tmpaa + codebb = registerCode registerbb tmpbb + srcbb = registerName registerbb tmpbb + + insn = case mop of MO_NatS_AddC -> ADD; MO_NatS_SubC -> SUB + MO_NatS_MulC -> IMUL + cond = if mop == MO_NatS_MulC then OFLO else CARRY + str = showSDoc (pprMachOp mop) + + code = toOL [ + COMMENT (_PK_ ("begin " ++ str)), + MOV L (OpReg srcbb) (OpReg tmp), + insn L (OpReg srcaa) (OpReg tmp), + MOV L (OpReg tmp) (OpReg rr), + MOV L (OpImm (ImmInt 0)) (OpReg eax), + SETCC cond (OpReg eax), + MOV L (OpReg eax) (OpReg cc), + COMMENT (_PK_ ("end " ++ str)) + ] + in + returnNat (codeaa `appOL` codebb `appOL` code) + + #endif {- i386_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if sparc_TARGET_ARCH @@ -1239,7 +1238,7 @@ temporary, then do the other computation, and then use the temporary: ... (tmp) ... \begin{code} -getAmode :: StixTree -> NatM Amode +getAmode :: StixExpr -> NatM Amode getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree) @@ -1285,7 +1284,9 @@ getAmode other -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if i386_TARGET_ARCH -getAmode (StPrim IntSubOp [x, StInt i]) +-- This is all just ridiculous, since it carefully undoes +-- what mangleIndexTree has just done. +getAmode (StMachOp MO_Nat_Sub [x, StInt i]) = getNewRegNCG PtrRep `thenNat` \ tmp -> getRegister x `thenNat` \ register -> let @@ -1295,14 +1296,14 @@ getAmode (StPrim IntSubOp [x, StInt i]) in returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code) -getAmode (StPrim IntAddOp [x, StInt i]) +getAmode (StMachOp MO_Nat_Add [x, StInt i]) | maybeToBool imm = returnNat (Amode (ImmAddr imm__2 (fromInteger i)) nilOL) where imm = maybeImm x imm__2 = case imm of Just x -> x -getAmode (StPrim IntAddOp [x, StInt i]) +getAmode (StMachOp MO_Nat_Add [x, StInt i]) = getNewRegNCG PtrRep `thenNat` \ tmp -> getRegister x `thenNat` \ register -> let @@ -1312,7 +1313,7 @@ getAmode (StPrim IntAddOp [x, StInt i]) in returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code) -getAmode (StPrim IntAddOp [x, StPrim SllOp [y, StInt shift]]) +getAmode (StMachOp MO_Nat_Add [x, StMachOp MO_Nat_Shl [y, StInt shift]]) | shift == 0 || shift == 1 || shift == 2 || shift == 3 = getNewRegNCG PtrRep `thenNat` \ tmp1 -> getNewRegNCG IntRep `thenNat` \ tmp2 -> @@ -1428,7 +1429,7 @@ condCode (CondCode _ _ code) = code Set up a condition code for a conditional branch. \begin{code} -getCondCode :: StixTree -> NatM CondCode +getCondCode :: StixExpr -> NatM CondCode #if alpha_TARGET_ARCH getCondCode = panic "MachCode.getCondCode: not on Alphas" @@ -1438,49 +1439,43 @@ getCondCode = panic "MachCode.getCondCode: not on Alphas" #if i386_TARGET_ARCH || sparc_TARGET_ARCH -- yes, they really do seem to want exactly the same! -getCondCode (StPrim primop [x, y]) - = case primop of - CharGtOp -> condIntCode GTT x y - CharGeOp -> condIntCode GE x y - CharEqOp -> condIntCode EQQ x y - CharNeOp -> condIntCode NE x y - CharLtOp -> condIntCode LTT x y - CharLeOp -> condIntCode LE x y +getCondCode (StMachOp mop [x, y]) + = case mop of + MO_32U_Gt -> condIntCode GTT x y + MO_32U_Ge -> condIntCode GE x y + MO_32U_Eq -> condIntCode EQQ x y + MO_32U_Ne -> condIntCode NE x y + MO_32U_Lt -> condIntCode LTT x y + MO_32U_Le -> condIntCode LE x y - IntGtOp -> condIntCode GTT x y - IntGeOp -> condIntCode GE x y - IntEqOp -> condIntCode EQQ x y - IntNeOp -> condIntCode NE x y - IntLtOp -> condIntCode LTT x y - IntLeOp -> condIntCode LE x y - - WordGtOp -> condIntCode GU x y - WordGeOp -> condIntCode GEU x y - WordEqOp -> condIntCode EQQ x y - WordNeOp -> condIntCode NE x y - WordLtOp -> condIntCode LU x y - WordLeOp -> condIntCode LEU x y - - AddrGtOp -> condIntCode GU x y - AddrGeOp -> condIntCode GEU x y - AddrEqOp -> condIntCode EQQ x y - AddrNeOp -> condIntCode NE x y - AddrLtOp -> condIntCode LU x y - AddrLeOp -> condIntCode LEU x y - - FloatGtOp -> condFltCode GTT x y - FloatGeOp -> condFltCode GE x y - FloatEqOp -> condFltCode EQQ x y - FloatNeOp -> condFltCode NE x y - FloatLtOp -> condFltCode LTT x y - FloatLeOp -> condFltCode LE x y - - DoubleGtOp -> condFltCode GTT x y - DoubleGeOp -> condFltCode GE x y - DoubleEqOp -> condFltCode EQQ x y - DoubleNeOp -> condFltCode NE x y - DoubleLtOp -> condFltCode LTT x y - DoubleLeOp -> condFltCode LE x y + MO_Nat_Eq -> condIntCode EQQ x y + MO_Nat_Ne -> condIntCode NE x y + + MO_NatS_Gt -> condIntCode GTT x y + MO_NatS_Ge -> condIntCode GE x y + MO_NatS_Lt -> condIntCode LTT x y + MO_NatS_Le -> condIntCode LE x y + + MO_NatU_Gt -> condIntCode GU x y + MO_NatU_Ge -> condIntCode GEU x y + MO_NatU_Lt -> condIntCode LU x y + MO_NatU_Le -> condIntCode LEU x y + + MO_Flt_Gt -> condFltCode GTT x y + MO_Flt_Ge -> condFltCode GE x y + MO_Flt_Eq -> condFltCode EQQ x y + MO_Flt_Ne -> condFltCode NE x y + MO_Flt_Lt -> condFltCode LTT x y + MO_Flt_Le -> condFltCode LE x y + + MO_Dbl_Gt -> condFltCode GTT x y + MO_Dbl_Ge -> condFltCode GE x y + MO_Dbl_Eq -> condFltCode EQQ x y + MO_Dbl_Ne -> condFltCode NE x y + MO_Dbl_Lt -> condFltCode LTT x y + MO_Dbl_Le -> condFltCode LE x y + + other -> pprPanic "getCondCode(x86,sparc)" (pprMachOp mop) #endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -} \end{code} @@ -1491,7 +1486,7 @@ getCondCode (StPrim primop [x, y]) passed back up the tree. \begin{code} -condIntCode, condFltCode :: Cond -> StixTree -> StixTree -> NatM CondCode +condIntCode, condFltCode :: Cond -> StixExpr -> StixExpr -> NatM CondCode #if alpha_TARGET_ARCH condIntCode = panic "MachCode.condIntCode: not on Alphas" @@ -1735,8 +1730,11 @@ generation for the right hand side. This only fails when the right hand side is forced into a fixed register (e.g. the result of a call). \begin{code} -assignIntCode, assignFltCode - :: PrimRep -> StixTree -> StixTree -> NatM InstrBlock +assignMem_IntCode :: PrimRep -> StixExpr -> StixExpr -> NatM InstrBlock +assignReg_IntCode :: PrimRep -> StixReg -> StixExpr -> NatM InstrBlock + +assignMem_FltCode :: PrimRep -> StixExpr -> StixExpr -> NatM InstrBlock +assignReg_FltCode :: PrimRep -> StixReg -> StixExpr -> NatM InstrBlock #if alpha_TARGET_ARCH @@ -1771,10 +1769,9 @@ assignIntCode pk dst src -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if i386_TARGET_ARCH --- Destination of an assignment can only be reg or mem. --- This is the mem case. -assignIntCode pk (StInd _ dst) src - = getAmode dst `thenNat` \ amode -> +-- non-FP assignment to memory +assignMem_IntCode pk addr src + = getAmode addr `thenNat` \ amode -> get_op_RI src `thenNat` \ (codesrc, opsrc) -> getNewRegNCG PtrRep `thenNat` \ tmp -> let @@ -1801,7 +1798,7 @@ assignIntCode pk (StInd _ dst) src returnNat code where get_op_RI - :: StixTree + :: StixExpr -> NatM (InstrBlock,Operand) -- code, operator get_op_RI op @@ -1818,15 +1815,13 @@ assignIntCode pk (StInd _ dst) src returnNat (code, OpReg reg) -- Assign; dst is a reg, rhs is mem -assignIntCode pk dst (StInd pks src) +assignReg_IntCode pk reg (StInd pks src) = getNewRegNCG PtrRep `thenNat` \ tmp -> getAmode src `thenNat` \ amode -> - getRegister dst `thenNat` \ reg_dst -> + getRegisterReg reg `thenNat` \ reg_dst -> let c_addr = amodeCode amode am_addr = amodeAddr amode - - c_dst = registerCode reg_dst tmp -- should be empty r_dst = registerName reg_dst tmp szs = primRepToSize pks opc = case szs of @@ -1837,30 +1832,23 @@ assignIntCode pk dst (StInd pks src) L -> MOV L Lu -> MOV L - code | isNilOL c_dst - = c_addr `snocOL` + code = c_addr `snocOL` opc (OpAddr am_addr) (OpReg r_dst) - | otherwise - = panic "assignIntCode(x86): bad dst(2)" in returnNat code -- dst is a reg, but src could be anything -assignIntCode pk dst src - = getRegister dst `thenNat` \ registerd -> +assignReg_IntCode pk reg src + = getRegisterReg reg `thenNat` \ registerd -> getRegister src `thenNat` \ registers -> getNewRegNCG IntRep `thenNat` \ tmp -> let r_dst = registerName registerd tmp - c_dst = registerCode registerd tmp -- should be empty r_src = registerName registers r_dst c_src = registerCode registers r_dst - code | isNilOL c_dst - = c_src `snocOL` + code = c_src `snocOL` MOV L (OpReg r_src) (OpReg r_dst) - | otherwise - = panic "assignIntCode(x86): bad dst(3)" in returnNat code @@ -1935,11 +1923,8 @@ assignFltCode pk dst src -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if i386_TARGET_ARCH --- dst is memory -assignFltCode pk (StInd pk_dst addr) src - | pk /= pk_dst - = panic "assignFltCode(x86): src/ind sz mismatch" - | otherwise +-- Floating point assignment to memory +assignMem_FltCode pk addr src = getRegister src `thenNat` \ reg_src -> getRegister addr `thenNat` \ reg_addr -> getNewRegNCG pk `thenNat` \ tmp_src -> @@ -1960,24 +1945,19 @@ assignFltCode pk (StInd pk_dst addr) src in returnNat code --- dst must be a (FP) register -assignFltCode pk dst src - = getRegister dst `thenNat` \ reg_dst -> +-- Floating point assignment to a register/temporary +assignReg_FltCode pk reg src + = getRegisterReg reg `thenNat` \ reg_dst -> getRegister src `thenNat` \ reg_src -> getNewRegNCG pk `thenNat` \ tmp -> let r_dst = registerName reg_dst tmp - c_dst = registerCode reg_dst tmp -- should be empty - r_src = registerName reg_src r_dst c_src = registerCode reg_src r_dst - code | isNilOL c_dst - = if isFixed reg_src + code = if isFixed reg_src then c_src `snocOL` GMOV r_src r_dst else c_src - | otherwise - = panic "assignFltCode(x86): lhs is not mem or reg" in returnNat code @@ -2055,7 +2035,7 @@ branch instruction. Other CLabels are assumed to be far away. register allocator. \begin{code} -genJump :: DestInfo -> StixTree{-the branch target-} -> NatM InstrBlock +genJump :: DestInfo -> StixExpr{-the branch target-} -> NatM InstrBlock #if alpha_TARGET_ARCH @@ -2157,7 +2137,7 @@ allocator. \begin{code} genCondJump :: CLabel -- the branch target - -> StixTree -- the condition on which to branch + -> StixExpr -- the condition on which to branch -> NatM InstrBlock #if alpha_TARGET_ARCH @@ -2354,7 +2334,7 @@ genCCall :: FAST_STRING -- function to call -> CCallConv -> PrimRep -- type of the result - -> [StixTree] -- arguments (of mixed type) + -> [StixExpr] -- arguments (of mixed type) -> NatM InstrBlock #if alpha_TARGET_ARCH @@ -2482,7 +2462,7 @@ genCCall fn cconv kind args arg_size _ = 4 ------------ - get_call_arg :: StixTree{-current argument-} + get_call_arg :: StixExpr{-current argument-} -> NatM (Int, InstrBlock) -- argsz, code get_call_arg arg @@ -2506,7 +2486,7 @@ genCCall fn cconv kind args ) ------------ get_op - :: StixTree + :: StixExpr -> NatM (InstrBlock, Reg, Size) -- code, reg, size get_op op @@ -2665,7 +2645,7 @@ the right hand side of an assignment). register allocator. \begin{code} -condIntReg, condFltReg :: Cond -> StixTree -> StixTree -> NatM Register +condIntReg, condFltReg :: Cond -> StixExpr -> StixExpr -> NatM Register #if alpha_TARGET_ARCH condIntReg = panic "MachCode.condIntReg (not on Alpha)" @@ -2827,7 +2807,7 @@ trivialCode -> Maybe (Operand -> Operand -> Instr) ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr) ,))) - -> StixTree -> StixTree -- the two arguments + -> StixExpr -> StixExpr -- the two arguments -> NatM Register trivialFCode @@ -2836,7 +2816,7 @@ trivialFCode ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr) ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr) ,))) - -> StixTree -> StixTree -- the two arguments + -> StixExpr -> StixExpr -- the two arguments -> NatM Register trivialUCode @@ -2844,7 +2824,7 @@ trivialUCode ,IF_ARCH_i386 ((Operand -> Instr) ,IF_ARCH_sparc((RI -> Reg -> Instr) ,))) - -> StixTree -- the one argument + -> StixExpr -- the one argument -> NatM Register trivialUFCode @@ -2853,7 +2833,7 @@ trivialUFCode ,IF_ARCH_i386 ((Reg -> Reg -> Instr) ,IF_ARCH_sparc((Reg -> Reg -> Instr) ,))) - -> StixTree -- the one argument + -> StixExpr -- the one argument -> NatM Register #if alpha_TARGET_ARCH @@ -3207,11 +3187,11 @@ conversions. We have to store temporaries in memory to move between the integer and the floating point register sets. \begin{code} -coerceIntCode :: PrimRep -> StixTree -> NatM Register -coerceFltCode :: StixTree -> NatM Register +coerceIntCode :: PrimRep -> StixExpr -> NatM Register +coerceFltCode :: StixExpr -> NatM Register -coerceInt2FP :: PrimRep -> StixTree -> NatM Register -coerceFP2Int :: StixTree -> NatM Register +coerceInt2FP :: PrimRep -> StixExpr -> NatM Register +coerceFP2Int :: StixExpr -> NatM Register coerceIntCode pk x = getRegister x `thenNat` \ register -> @@ -3339,7 +3319,7 @@ coerceFP2Int x Integer to character conversion. \begin{code} -chrCode :: StixTree -> NatM Register +chrCode :: StixExpr -> NatM Register #if alpha_TARGET_ARCH diff --git a/ghc/compiler/nativeGen/MachMisc.lhs b/ghc/compiler/nativeGen/MachMisc.lhs index b72706e7c1..ce88dd3f14 100644 --- a/ghc/compiler/nativeGen/MachMisc.lhs +++ b/ghc/compiler/nativeGen/MachMisc.lhs @@ -42,21 +42,24 @@ import AbsCSyn ( MagicId(..) ) import AbsCUtils ( magicIdPrimRep ) import CLabel ( CLabel, isAsmTemp ) import Literal ( mkMachInt, Literal(..) ) -import MachRegs ( stgReg, callerSaves, RegLoc(..), - Imm(..), Reg(..), - MachRegsAddr(..) +import MachRegs ( callerSaves, + get_MagicId_addr, get_MagicId_reg_or_addr, + Imm(..), Reg(..), MachRegsAddr(..) # if sparc_TARGET_ARCH ,fp, sp # endif ) import PrimRep ( PrimRep(..) ) -import Stix ( StixTree(..), StixReg(..), CodeSegment, DestInfo(..) ) +import Stix ( StixStmt(..), StixExpr(..), StixReg(..), + CodeSegment, DestInfo(..) ) import Panic ( panic ) import GlaExts ( word2Int#, int2Word#, shiftRL#, and#, (/=#) ) import Outputable ( pprPanic, ppr, showSDoc ) import IOExts ( trace ) import Config ( cLeadingUnderscore ) import FastTypes + +import Maybe ( catMaybes ) \end{code} \begin{code} @@ -110,30 +113,45 @@ constants. (@volatileRestores@ used only for wrapper-hungry PrimOps.) \begin{code} -volatileSaves, volatileRestores :: [MagicId] -> [StixTree] +volatileSaves, volatileRestores :: [MagicId] -> [StixStmt] + +volatileSaves = volatileSavesOrRestores True +volatileRestores = volatileSavesOrRestores False save_cands = [BaseReg,Sp,Su,SpLim,Hp,HpLim] restore_cands = save_cands -volatileSaves vols - = map save ((filter callerSaves) (save_cands ++ vols)) - where - save x = StAssign (magicIdPrimRep x) loc reg - where - reg = StReg (StixMagicId x) - loc = case stgReg x of - Save loc -> loc - Always _ -> panic "volatileSaves" - -volatileRestores vols - = map restore ((filter callerSaves) (restore_cands ++ vols)) - where - restore x = StAssign (magicIdPrimRep x) reg loc - where - reg = StReg (StixMagicId x) - loc = case stgReg x of - Save loc -> loc - Always _ -> panic "volatileRestores" +volatileSavesOrRestores do_saves vols + = catMaybes (map mkCode vols) + where + mkCode mid + | not (callerSaves mid) + = Nothing + | otherwise -- must be callee-saves ... + = case get_MagicId_reg_or_addr mid of + -- If stored in BaseReg, we ain't interested + Right baseRegAddr + -> Nothing + Left (RealReg rrno) + -- OK, it's callee-saves, and in a real reg (rrno). + -- We have to cook up some transfer code. + {- Note that the use of (StixMagicId mid) here is a bit subtle. + Here, we only create those for MagicIds which are stored in + a real reg on this arch -- the preceding case on the result + of get_MagicId_reg_or_addr guarantees this. Later, when + selecting insns, that means these assignments are sure to turn + into real reg-to-mem or mem-to-reg moves, rather than being + pointless moves from some address in the reg-table + back to itself.-} + | do_saves + -> Just (StAssignMem rep addr + (StReg (StixMagicId mid))) + | otherwise + -> Just (StAssignReg rep (StixMagicId mid) + (StInd rep addr)) + where + rep = magicIdPrimRep mid + addr = get_MagicId_addr mid \end{code} % - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -206,6 +224,8 @@ data Cond | NE | NEG | POS + | CARRY + | OFLO #endif #if sparc_TARGET_ARCH = ALWAYS -- What's really used? ToDo @@ -291,6 +311,7 @@ primRepToSize WeakPtrRep = IF_ARCH_alpha(Q, IF_ARCH_i386(L, IF_ARCH_sparc(W primRepToSize ForeignObjRep = IF_ARCH_alpha(Q, IF_ARCH_i386(L, IF_ARCH_sparc(W, ))) primRepToSize BCORep = IF_ARCH_alpha(Q, IF_ARCH_i386(L, IF_ARCH_sparc(W, ))) primRepToSize StablePtrRep = IF_ARCH_alpha(Q, IF_ARCH_i386(L, IF_ARCH_sparc(W, ))) +primRepToSize StableNameRep = IF_ARCH_alpha(Q, IF_ARCH_i386(L, IF_ARCH_sparc(W, ))) primRepToSize ThreadIdRep = IF_ARCH_alpha(Q, IF_ARCH_i386(L, IF_ARCH_sparc(W, ))) primRepToSize Word64Rep = primRepToSize_fail "Word64Rep" @@ -476,14 +497,17 @@ but we don't care, since it doesn't get used much. We hope. | ADD Size Operand Operand | SUB Size Operand Operand - | IMUL Size Operand Operand + | IMUL Size Operand Operand -- signed int mul + | MUL Size Operand Operand -- unsigned int mul -- Quotient and remainder. SEE comment above -- these are not -- real x86 insns; instead they are expanded when printed -- into a sequence of real insns. - | IQUOT Size Operand Operand - | IREM Size Operand Operand + | IQUOT Size Operand Operand -- signed quotient + | IREM Size Operand Operand -- signed remainder + | QUOT Size Operand Operand -- unsigned quotient + | REM Size Operand Operand -- unsigned remainder -- Simple bit-twiddling. @@ -513,10 +537,7 @@ but we don't care, since it doesn't get used much. We hope. | GLDZ Reg -- dst(fpreg) | GLD1 Reg -- dst(fpreg) - | GFTOD Reg Reg -- src(fpreg), dst(fpreg) | GFTOI Reg Reg -- src(fpreg), dst(intreg) - - | GDTOF Reg Reg -- src(fpreg), dst(fpreg) | GDTOI Reg Reg -- src(fpreg), dst(intreg) | GITOF Reg Reg -- src(intreg), dst(fpreg) @@ -592,8 +613,7 @@ is_G_instr instr = case instr of GMOV _ _ -> True; GLD _ _ _ -> True; GST _ _ _ -> True; GLDZ _ -> True; GLD1 _ -> True; - GFTOD _ _ -> True; GFTOI _ _ -> True; - GDTOF _ _ -> True; GDTOI _ _ -> True; + GFTOI _ _ -> True; GDTOI _ _ -> True; GITOF _ _ -> True; GITOD _ _ -> True; GADD _ _ _ _ -> True; GDIV _ _ _ _ -> True GSUB _ _ _ _ -> True; GMUL _ _ _ _ -> True diff --git a/ghc/compiler/nativeGen/MachRegs.lhs b/ghc/compiler/nativeGen/MachRegs.lhs index 0dce2fe99a..1e6d0b59d3 100644 --- a/ghc/compiler/nativeGen/MachRegs.lhs +++ b/ghc/compiler/nativeGen/MachRegs.lhs @@ -20,7 +20,6 @@ module MachRegs ( Imm(..), MachRegsAddr(..), - RegLoc(..), addrOffset, baseRegOffset, @@ -28,11 +27,10 @@ module MachRegs ( freeReg, getNewRegNCG, mkVReg, - magicIdRegMaybe, - saveLoc, + get_MagicId_reg_or_addr, + get_MagicId_addr, + get_Regtable_addr_from_offset, spRel, - stgReg, - regTableEntry, strImmLit #if alpha_TARGET_ARCH @@ -56,11 +54,10 @@ module MachRegs ( #include "HsVersions.h" import AbsCSyn ( MagicId(..) ) -import AbsCUtils ( magicIdPrimRep ) import CLabel ( CLabel, mkMainRegTableLabel ) -import PrimOp ( PrimOp(..) ) +import MachOp ( MachOp(..) ) import PrimRep ( PrimRep(..), isFloatingRep ) -import Stix ( StixTree(..), StixReg(..), +import Stix ( StixExpr(..), StixReg(..), getUniqueNat, returnNat, thenNat, NatM ) import Unique ( mkPseudoUnique2, Uniquable(..), Unique ) import Pretty @@ -171,42 +168,34 @@ largeOffsetError i % - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -@stgReg@: we map STG registers onto appropriate Stix Trees. First, we -handle the two constants, @STK_STUB_closure@ and @vtbl_StdUpdFrame@. -The rest are either in real machine registers or stored as offsets -from BaseReg. +@stgReg@: we map STG registers onto appropriate Stix Trees. Either +they map to real machine registers or stored as offsets from BaseReg. +Given a MagicId, get_MagicId_reg_or_addr produces either the real +register it is in, on this platform, or a StixExpr denoting the +address in the register table holding it. get_MagicId_addr always +produces the register table address for it. \begin{code} -data RegLoc = Save StixTree | Always StixTree -\end{code} - -Trees for register save locations: -\begin{code} -saveLoc :: MagicId -> StixTree -saveLoc reg = case (stgReg reg) of {Always loc -> loc; Save loc -> loc} -\end{code} - -\begin{code} -stgReg :: MagicId -> RegLoc -stgReg BaseReg - = case magicIdRegMaybe BaseReg of - Nothing -> Always (StCLbl mkMainRegTableLabel) - Just _ -> Save (StCLbl mkMainRegTableLabel) -stgReg x - = case magicIdRegMaybe x of - Just _ -> Save stix - Nothing -> Always stix - where - stix = regTableEntry (magicIdPrimRep x) (baseRegOffset x) - -regTableEntry :: PrimRep -> Int -> StixTree -regTableEntry rep offset - = StInd rep (StPrim IntAddOp - [baseLoc, StInt (toInteger (offset*BYTES_PER_WORD))]) - where - baseLoc = case (magicIdRegMaybe BaseReg) of - Just _ -> StReg (StixMagicId BaseReg) - Nothing -> StCLbl mkMainRegTableLabel +get_MagicId_reg_or_addr :: MagicId -> Either Reg StixExpr +get_MagicId_addr :: MagicId -> StixExpr +get_Regtable_addr_from_offset :: Int -> StixExpr + +get_MagicId_reg_or_addr mid + = case magicIdRegMaybe mid of + Just rr -> Left rr + Nothing -> Right (get_MagicId_addr mid) + +get_MagicId_addr BaseReg + = panic "MachRegs.get_MagicId_addr of BaseReg" +get_MagicId_addr mid + = get_Regtable_addr_from_offset (baseRegOffset mid) + +get_Regtable_addr_from_offset offset_in_words + = case magicIdRegMaybe BaseReg of + Nothing -> panic "MachRegs.get_Regtable_addr_from_offset: BaseReg not in a reg" + Just rr -> StMachOp MO_Nat_Add + [StReg (StixMagicId BaseReg), + StInt (toInteger (offset_in_words*BYTES_PER_WORD))] \end{code} % - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/ghc/compiler/nativeGen/PprMach.lhs b/ghc/compiler/nativeGen/PprMach.lhs index 273a679da2..b873dcd383 100644 --- a/ghc/compiler/nativeGen/PprMach.lhs +++ b/ghc/compiler/nativeGen/PprMach.lhs @@ -249,6 +249,7 @@ pprCond c = ptext (case c of { LTT -> SLIT("l"); LE -> SLIT("le"); LEU -> SLIT("be"); NE -> SLIT("ne"); NEG -> SLIT("s"); POS -> SLIT("ns"); + CARRY -> SLIT("c"); OFLO -> SLIT("o"); ALWAYS -> SLIT("mp") -- hack #endif #if sparc_TARGET_ARCH @@ -939,6 +940,15 @@ pprInstr (ADD size src dst) pprInstr (SUB size src dst) = pprSizeOpOp SLIT("sub") size src dst pprInstr (IMUL size op1 op2) = pprSizeOpOp SLIT("imul") size op1 op2 +{- A hack. The Intel documentation says that "The two and three + operand forms [of IMUL] may also be used with unsigned operands + because the lower half of the product is the same regardless if + (sic) the operands are signed or unsigned. The CF and OF flags, + however, cannot be used to determine if the upper half of the + result is non-zero." So there. +-} +pprInstr (MUL size op1 op2) = pprSizeOpOp SLIT("imul") size op1 op2 + pprInstr (AND size src dst) = pprSizeOpOp SLIT("and") size src dst pprInstr (OR size src dst) = pprSizeOpOp SLIT("or") size src dst pprInstr (XOR size src dst) = pprSizeOpOp SLIT("xor") size src dst @@ -968,8 +978,12 @@ pprInstr (JMP dsts (OpImm imm)) = (<>) (ptext SLIT("\tjmp ")) (pprImm imm) pprInstr (JMP dsts op) = (<>) (ptext SLIT("\tjmp *")) (pprOperand L op) pprInstr (CALL imm) = (<>) (ptext SLIT("\tcall ")) (pprImm imm) -pprInstr (IQUOT sz src dst) = pprInstr_quotRem True sz src dst -pprInstr (IREM sz src dst) = pprInstr_quotRem False sz src dst +-- First bool indicates signedness; second whether quot or rem +pprInstr (IQUOT sz src dst) = pprInstr_quotRem True True sz src dst +pprInstr (IREM sz src dst) = pprInstr_quotRem True False sz src dst + +pprInstr (QUOT sz src dst) = pprInstr_quotRem False True sz src dst +pprInstr (REM sz src dst) = pprInstr_quotRem False False sz src dst -- Simulating a flat register set on the x86 FP stack is tricky. -- you have to free %st(7) before pushing anything on the FP reg stack @@ -995,15 +1009,12 @@ pprInstr g@(GLDZ dst) pprInstr g@(GLD1 dst) = pprG g (hcat [gtab, text "ffree %st(7) ; fld1 ; ", gpop dst 1]) -pprInstr g@(GFTOD src dst) - = pprG g bogus pprInstr g@(GFTOI src dst) - = pprG g bogus - -pprInstr g@(GDTOF src dst) - = pprG g bogus + = pprInstr (GDTOI src dst) pprInstr g@(GDTOI src dst) - = pprG g bogus + = pprG g (hcat [gtab, text "subl $4, %esp ; ", + gpush src 0, gsemi, text "fistpl 0(%esp) ; popl ", + pprReg L dst]) pprInstr g@(GITOF src dst) = pprInstr (GITOD src dst) @@ -1108,7 +1119,7 @@ pprInstr GFREE ] -pprInstr_quotRem isQuot sz src dst +pprInstr_quotRem signed isQuot sz src dst | case sz of L -> False; _ -> True = panic "pprInstr_quotRem: dunno how to do non-32bit operands" | otherwise @@ -1116,20 +1127,23 @@ pprInstr_quotRem isQuot sz src dst (text "\t# BEGIN " <> fakeInsn), (text "\tpushl $0; pushl %eax; pushl %edx; pushl " <> pprOperand sz src), (text "\tmovl " <> pprOperand sz dst <> text ",%eax; xorl %edx,%edx; cltd"), - (text "\tdivl 0(%esp); movl " <> text resReg <> text ",12(%esp)"), + (x86op <> text " 0(%esp); movl " <> text resReg <> text ",12(%esp)"), (text "\tpopl %edx; popl %edx; popl %eax; popl " <> pprOperand sz dst), (text "\t# END " <> fakeInsn) ] where + x86op = if signed then text "\tidivl" else text "\tdivl" resReg = if isQuot then "%eax" else "%edx" - opStr = if isQuot then "IQUOT" else "IREM" - fakeInsn = text opStr <+> pprOperand sz src <> char ',' <+> pprOperand sz dst + opStr | signed = if isQuot then "IQUOT" else "IREM" + | not signed = if isQuot then "QUOT" else "REM" + fakeInsn = text opStr <+> pprOperand sz src + <> char ',' <+> pprOperand sz dst -------------------------- -- coerce %st(0) to the specified size gcoerceto DF = empty -gcoerceto F = text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ; " +gcoerceto F = empty --text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ; " gpush reg offset = hcat [text "ffree %st(7) ; fld ", greg reg offset] @@ -1157,10 +1171,7 @@ pprGInstr (GST sz src dst) = pprSizeRegAddr SLIT("gst") sz src dst pprGInstr (GLDZ dst) = pprSizeReg SLIT("gldz") DF dst pprGInstr (GLD1 dst) = pprSizeReg SLIT("gld1") DF dst -pprGInstr (GFTOD src dst) = pprSizeSizeRegReg SLIT("gftod") F DF src dst pprGInstr (GFTOI src dst) = pprSizeSizeRegReg SLIT("gftoi") F L src dst - -pprGInstr (GDTOF src dst) = pprSizeSizeRegReg SLIT("gdtof") DF F src dst pprGInstr (GDTOI src dst) = pprSizeSizeRegReg SLIT("gdtoi") DF L src dst pprGInstr (GITOF src dst) = pprSizeSizeRegReg SLIT("gitof") L F src dst diff --git a/ghc/compiler/nativeGen/RegAllocInfo.lhs b/ghc/compiler/nativeGen/RegAllocInfo.lhs index 7fd7e91fe1..f64ba40b37 100644 --- a/ghc/compiler/nativeGen/RegAllocInfo.lhs +++ b/ghc/compiler/nativeGen/RegAllocInfo.lhs @@ -236,8 +236,11 @@ regUsage instr = case instr of ADD sz src dst -> usageRM src dst SUB sz src dst -> usageRM src dst IMUL sz src dst -> usageRM src dst + MUL sz src dst -> usageRM src dst IQUOT sz src dst -> usageRM src dst IREM sz src dst -> usageRM src dst + QUOT sz src dst -> usageRM src dst + REM sz src dst -> usageRM src dst AND sz src dst -> usageRM src dst OR sz src dst -> usageRM src dst XOR sz src dst -> usageRM src dst @@ -266,10 +269,7 @@ regUsage instr = case instr of GLDZ dst -> mkRU [] [dst] GLD1 dst -> mkRU [] [dst] - GFTOD src dst -> mkRU [src] [dst] GFTOI src dst -> mkRU [src] [dst] - - GDTOF src dst -> mkRU [src] [dst] GDTOI src dst -> mkRU [src] [dst] GITOF src dst -> mkRU [src] [dst] @@ -627,8 +627,11 @@ patchRegs instr env = case instr of ADD sz src dst -> patch2 (ADD sz) src dst SUB sz src dst -> patch2 (SUB sz) src dst IMUL sz src dst -> patch2 (IMUL sz) src dst + MUL sz src dst -> patch2 (MUL sz) src dst IQUOT sz src dst -> patch2 (IQUOT sz) src dst IREM sz src dst -> patch2 (IREM sz) src dst + QUOT sz src dst -> patch2 (QUOT sz) src dst + REM sz src dst -> patch2 (REM sz) src dst AND sz src dst -> patch2 (AND sz) src dst OR sz src dst -> patch2 (OR sz) src dst XOR sz src dst -> patch2 (XOR sz) src dst @@ -652,10 +655,7 @@ patchRegs instr env = case instr of GLDZ dst -> GLDZ (env dst) GLD1 dst -> GLD1 (env dst) - GFTOD src dst -> GFTOD (env src) (env dst) GFTOI src dst -> GFTOI (env src) (env dst) - - GDTOF src dst -> GDTOF (env src) (env dst) GDTOI src dst -> GDTOI (env src) (env dst) GITOF src dst -> GITOF (env src) (env dst) diff --git a/ghc/compiler/nativeGen/Stix.lhs b/ghc/compiler/nativeGen/Stix.lhs index e8c27d1d13..951cfb682c 100644 --- a/ghc/compiler/nativeGen/Stix.lhs +++ b/ghc/compiler/nativeGen/Stix.lhs @@ -4,9 +4,11 @@ \begin{code} module Stix ( - CodeSegment(..), StixReg(..), StixTree(..), StixTreeList, - pprStixTrees, pprStixTree, ppStixReg, - stixCountTempUses, stixSubst, + CodeSegment(..), StixReg(..), StixExpr(..), StixVReg(..), + StixStmt(..), mkStAssign, StixStmtList, + pprStixStmts, pprStixStmt, pprStixExpr, pprStixReg, + stixStmt_CountTempUses, stixStmt_Subst, + liftStrings, DestInfo(..), hasDestInfo, stgBaseReg, stgNode, stgSp, stgSu, stgSpLim, @@ -35,54 +37,45 @@ import AbsCSyn ( node, tagreg, MagicId(..) ) import ForeignCall ( CCallConv ) import CLabel ( mkAsmTempLabel, CLabel, pprCLabel ) import PrimRep ( PrimRep(..) ) -import PrimOp ( PrimOp ) +import MachOp ( MachOp(..), pprMachOp ) import Unique ( Unique ) import SMRep ( fixedHdrSize, arrWordsHdrSize, arrPtrsHdrSize ) import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply, UniqSM, thenUs, returnUs, getUniqueUs ) +import Maybes ( Maybe012(..), maybe012ToList ) import Outputable import FastTypes \end{code} -Here is the tag at the nodes of our @StixTree@. Notice its -relationship with @PrimOp@ in prelude/PrimOp. +Two types, StixStmt and StixValue, define Stix. \begin{code} -data StixTree - = -- Segment (text or data) - StSegment CodeSegment - - -- We can tag the leaves with constants/immediates. - - | StInt Integer -- ** add Kind at some point - | StFloat Rational - | StDouble Rational - | StString FAST_STRING - | StCLbl CLabel -- labels that we might index into - - -- Abstract registers of various kinds - - | StReg StixReg +-- Non-value trees; ones executed for their side-effect. +data StixStmt - -- A typed offset from a base location - - | StIndex PrimRep StixTree StixTree -- kind, base, offset + = -- Directive for the assembler to change segment + StSegment CodeSegment - -- An indirection from an address to its contents. + -- Assembly-language comments + | StComment FAST_STRING - | StInd PrimRep StixTree + -- Assignments are typed to determine size and register placement. + -- Assign a value to a StixReg + | StAssignReg PrimRep StixReg StixExpr - -- Assignment is typed to determine size and register placement + -- Assign a value to memory. First tree indicates the address to be + -- assigned to, so there is an implicit dereference here. + | StAssignMem PrimRep StixExpr StixExpr -- dst, src - | StAssign PrimRep StixTree StixTree -- dst, src + -- Do a machine op which generates multiple values, and assign + -- the results to the lvalues stated here. + | StAssignMachOp (Maybe012 StixVReg) MachOp [StixExpr] -- A simple assembly label that we might jump to. - | StLabel CLabel -- A function header and footer - | StFunBegin CLabel | StFunEnd CLabel @@ -93,41 +86,71 @@ data StixTree -- the exact targets to be attached, so that the allocator can -- easily construct the exact flow edges leaving this insn. -- Dynamic targets are allowed. - - | StJump DestInfo StixTree + | StJump DestInfo StixExpr -- A fall-through, from slow to fast - | StFallThrough CLabel -- A conditional jump. This instruction can be non-terminal :-) -- Only static, local, forward labels are allowed - - | StCondJump CLabel StixTree + | StCondJump CLabel StixExpr -- Raw data (as in an info table). + | StData PrimRep [StixExpr] + -- String which has been lifted to the top level (sigh). + | StDataString FAST_STRING + + -- A value computed only for its side effects; result is discarded + -- (A handy trapdoor to allow CCalls with no results to appear as + -- statements). + | StVoidable StixExpr + + +-- Helper fn to make Stix assignment statements where the +-- lvalue masquerades as a StixExpr. A kludge that should +-- be done away with. +mkStAssign :: PrimRep -> StixExpr -> StixExpr -> StixStmt +mkStAssign rep (StReg reg) rhs + = StAssignReg rep reg rhs +mkStAssign rep (StInd rep' addr) rhs + | rep `isCloseEnoughTo` rep' + = StAssignMem rep addr rhs + | otherwise + = --pprPanic "Stix.mkStAssign: mismatched reps" (ppr rep <+> ppr rep') + --trace ("Stix.mkStAssign: mismatched reps: " ++ showSDoc (ppr rep <+> ppr rep')) ( + StAssignMem rep addr rhs + --) + where + isCloseEnoughTo r1 r2 + = r1 == r2 || (wordIsh r1 && wordIsh r2) + wordIsh rep + = rep `elem` [IntRep, WordRep, PtrRep, AddrRep, CodePtrRep, + RetRep, ArrayRep, PrimPtrRep, StableNameRep, BCORep] + -- determined by looking at PrimRep.showPrimRep + +-- Stix trees which denote a value. +data StixExpr + = -- Literals + StInt Integer -- ** add Kind at some point + | StFloat Rational + | StDouble Rational + | StString FAST_STRING + | StCLbl CLabel -- labels that we might index into - | StData PrimRep [StixTree] - - -- Primitive Operations - - | StPrim PrimOp [StixTree] - - -- Calls to C functions - - | StCall FAST_STRING CCallConv PrimRep [StixTree] + -- Abstract registers of various kinds + | StReg StixReg - -- A volatile memory scratch array, which is allocated - -- relative to the stack pointer. It is an array of - -- ptr/word/int sized things. Do not expect to be preserved - -- beyond basic blocks or over a ccall. Current max size - -- is 6, used in StixInteger. + -- A typed offset from a base location + | StIndex PrimRep StixExpr StixExpr -- kind, base, offset - | StScratchWord Int + -- An indirection from an address to its contents. + | StInd PrimRep StixExpr - -- Assembly-language comments + -- Primitive Operations + | StMachOp MachOp [StixExpr] - | StComment FAST_STRING + -- Calls to C functions + | StCall FAST_STRING CCallConv PrimRep [StixExpr] -- used by insnFuture in RegAllocInfo.lhs @@ -143,46 +166,64 @@ pprDests NoDestInfo = text "NoDestInfo" pprDests (DestInfo dsts) = brackets (hsep (map pprCLabel dsts)) -pprStixTrees :: [StixTree] -> SDoc -pprStixTrees ts +pprStixStmts :: [StixStmt] -> SDoc +pprStixStmts ts = vcat [ - vcat (map pprStixTree ts), + vcat (map pprStixStmt ts), char ' ', char ' ' ] -pprStixTree :: StixTree -> SDoc -pprStixTree t + +pprStixExpr :: StixExpr -> SDoc +pprStixExpr t = case t of - StSegment cseg -> parens (ppCodeSegment cseg) - StInt i -> parens (integer i) + StCLbl lbl -> pprCLabel lbl + StInt i -> (if i < 0 then parens else id) (integer i) StFloat rat -> parens (text "Float" <+> rational rat) StDouble rat -> parens (text "Double" <+> rational rat) StString str -> parens (text "Str `" <> ptext str <> char '\'') + StIndex k b o -> parens (pprStixExpr b <+> char '+' <> + ppr k <+> pprStixExpr o) + StInd k t -> ppr k <> char '[' <> pprStixExpr t <> char ']' + StReg reg -> pprStixReg reg + StMachOp op args -> pprMachOp op + <> parens (hsep (punctuate comma (map pprStixExpr args))) + StCall nm cc k args + -> parens (text "Call" <+> ptext nm <+> + ppr cc <+> ppr k <+> + hsep (map pprStixExpr args)) + +pprStixStmt :: StixStmt -> SDoc +pprStixStmt t + = case t of + StSegment cseg -> parens (ppCodeSegment cseg) StComment str -> parens (text "Comment" <+> ptext str) - StCLbl lbl -> pprCLabel lbl - StReg reg -> ppStixReg reg - StIndex k b o -> parens (pprStixTree b <+> char '+' <> - ppr k <+> pprStixTree o) - StInd k t -> ppr k <> char '[' <> pprStixTree t <> char ']' - StAssign k d s -> pprStixTree d <> text " :=" <> ppr k - <> text " " <> pprStixTree s + StAssignReg pr reg rhs + -> pprStixReg reg <> text " :=" <> ppr pr + <> text " " <> pprStixExpr rhs + StAssignMem pr addr rhs + -> ppr pr <> char '[' <> pprStixExpr addr <> char ']' + <> text " :=" <> ppr pr + <> text " " <> pprStixExpr rhs + StAssignMachOp lhss mop args + -> parens (hcat (punctuate comma ( + map pprStixVReg (maybe012ToList lhss) + ))) + <> text " := " + <> pprMachOp mop + <> parens (hsep (punctuate comma (map pprStixExpr args))) StLabel ll -> pprCLabel ll <+> char ':' StFunBegin ll -> char ' ' $$ parens (text "FunBegin" <+> pprCLabel ll) StFunEnd ll -> parens (text "FunEnd" <+> pprCLabel ll) - StJump dsts t -> parens (text "Jump" <+> pprDests dsts <+> pprStixTree t) + StJump dsts t -> parens (text "Jump" <+> pprDests dsts <+> pprStixExpr t) StFallThrough ll -> parens (text "FallThru" <+> pprCLabel ll) StCondJump l t -> parens (text "JumpC" <+> pprCLabel l - <+> pprStixTree t) + <+> pprStixExpr t) StData k ds -> parens (text "Data" <+> ppr k <+> - hsep (map pprStixTree ds)) - StPrim op ts -> parens (text "Prim" <+> ppr op <+> - hsep (map pprStixTree ts)) - StCall nm cc k args - -> parens (text "Call" <+> ptext nm <+> - ppr cc <+> ppr k <+> - hsep (map pprStixTree args)) - StScratchWord i -> text "ScratchWord" <> parens (int i) + hsep (map pprStixExpr ds)) + StDataString str -> parens (text "DataString" <+> ppr str) + StVoidable expr -> text "(void)" <+> pprStixExpr expr \end{code} Stix registers can have two forms. They {\em may} or {\em may not} @@ -192,13 +233,17 @@ map to real, machine-level registers. data StixReg = StixMagicId MagicId -- Regs which are part of the abstract machine model - | StixTemp Unique PrimRep -- "Regs" which model local variables (CTemps) in - -- the abstract C. + | StixTemp StixVReg -- "Regs" which model local variables (CTemps) in + -- the abstract C. + +pprStixReg (StixMagicId mid) = ppMId mid +pprStixReg (StixTemp temp) = pprStixVReg temp + +data StixVReg + = StixVReg Unique PrimRep + +pprStixVReg (StixVReg u pr) = hcat [text "VReg(", ppr u, ppr pr, char ')'] -ppStixReg (StixMagicId mid) - = ppMId mid -ppStixReg (StixTemp u pr) - = hcat [text "Temp(", ppr u, ppr pr, char ')'] ppMId BaseReg = text "BaseReg" @@ -222,30 +267,35 @@ segment (or that it has no segments at all, and we can lump these together). \begin{code} -data CodeSegment = DataSegment | TextSegment | RoDataSegment deriving (Eq, Show) +data CodeSegment + = DataSegment + | TextSegment + | RoDataSegment + deriving (Eq, Show) + ppCodeSegment = text . show -type StixTreeList = [StixTree] -> [StixTree] +type StixStmtList = [StixStmt] -> [StixStmt] \end{code} Stix Trees for STG registers: \begin{code} stgBaseReg, stgNode, stgSp, stgSu, stgSpLim, stgHp, stgHpLim - :: StixTree - -stgBaseReg = StReg (StixMagicId BaseReg) -stgNode = StReg (StixMagicId node) -stgTagReg = StReg (StixMagicId tagreg) -stgSp = StReg (StixMagicId Sp) -stgSu = StReg (StixMagicId Su) -stgSpLim = StReg (StixMagicId SpLim) -stgHp = StReg (StixMagicId Hp) -stgHpLim = StReg (StixMagicId HpLim) -stgHpAlloc = StReg (StixMagicId HpAlloc) -stgCurrentTSO = StReg (StixMagicId CurrentTSO) -stgCurrentNursery = StReg (StixMagicId CurrentNursery) -stgR9 = StReg (StixMagicId (VanillaReg WordRep (_ILIT 9))) -stgR10 = StReg (StixMagicId (VanillaReg WordRep (_ILIT 10))) + :: StixReg + +stgBaseReg = StixMagicId BaseReg +stgNode = StixMagicId node +stgTagReg = StixMagicId tagreg +stgSp = StixMagicId Sp +stgSu = StixMagicId Su +stgSpLim = StixMagicId SpLim +stgHp = StixMagicId Hp +stgHpLim = StixMagicId HpLim +stgHpAlloc = StixMagicId HpAlloc +stgCurrentTSO = StixMagicId CurrentTSO +stgCurrentNursery = StixMagicId CurrentNursery +stgR9 = StixMagicId (VanillaReg WordRep (_ILIT 9)) +stgR10 = StixMagicId (VanillaReg WordRep (_ILIT 10)) getNatLabelNCG :: NatM CLabel getNatLabelNCG @@ -267,83 +317,220 @@ given temporary appears in a tree, so as to be able to decide whether or not to inline the assignment's RHS at usage site(s). \begin{code} -stixCountTempUses :: Unique -> StixTree -> Int -stixCountTempUses u t - = let qq = stixCountTempUses u +stixExpr_CountTempUses :: Unique -> StixExpr -> Int +stixExpr_CountTempUses u t + = let qs = stixStmt_CountTempUses u + qe = stixExpr_CountTempUses u + qr = stixReg_CountTempUses u in case t of - StReg reg - -> case reg of - StixTemp uu pr -> if u == uu then 1 else 0 - StixMagicId mid -> 0 - - StIndex pk t1 t2 -> qq t1 + qq t2 - StInd pk t1 -> qq t1 - StAssign pk t1 t2 -> qq t1 + qq t2 - StJump dsts t1 -> qq t1 - StCondJump lbl t1 -> qq t1 - StData pk ts -> sum (map qq ts) - StPrim op ts -> sum (map qq ts) - StCall nm cconv pk ts -> sum (map qq ts) - - StSegment _ -> 0 + StReg reg -> qr reg + StIndex pk t1 t2 -> qe t1 + qe t2 + StInd pk t1 -> qe t1 + StMachOp mop ts -> sum (map qe ts) + StCall nm cconv pk ts -> sum (map qe ts) StInt _ -> 0 StFloat _ -> 0 StDouble _ -> 0 StString _ -> 0 StCLbl _ -> 0 - StLabel _ -> 0 + +stixStmt_CountTempUses :: Unique -> StixStmt -> Int +stixStmt_CountTempUses u t + = let qe = stixExpr_CountTempUses u + qr = stixReg_CountTempUses u + qv = stixVReg_CountTempUses u + in + case t of + StAssignReg pk reg rhs -> qr reg + qe rhs + StAssignMem pk addr rhs -> qe addr + qe rhs + StJump dsts t1 -> qe t1 + StCondJump lbl t1 -> qe t1 + StData pk ts -> sum (map qe ts) + StAssignMachOp lhss mop args + -> sum (map qv (maybe012ToList lhss)) + sum (map qe args) + StVoidable expr -> qe expr + StSegment _ -> 0 StFunBegin _ -> 0 StFunEnd _ -> 0 StFallThrough _ -> 0 - StScratchWord _ -> 0 StComment _ -> 0 + StLabel _ -> 0 + StDataString _ -> 0 + +stixReg_CountTempUses u reg + = case reg of + StixTemp vreg -> stixVReg_CountTempUses u vreg + StixMagicId mid -> 0 +stixVReg_CountTempUses u (StixVReg uu pr) + = if u == uu then 1 else 0 +\end{code} + +If we do decide to inline a temporary binding, the following functions +do the biz. -stixSubst :: Unique -> StixTree -> StixTree -> StixTree -stixSubst u new_u in_this_tree - = stixMapUniques f in_this_tree +\begin{code} +stixStmt_Subst :: Unique -> StixExpr -> StixStmt -> StixStmt +stixStmt_Subst u new_u in_this_tree + = stixStmt_MapUniques f in_this_tree where - f :: Unique -> Maybe StixTree + f :: Unique -> Maybe StixExpr f uu = if uu == u then Just new_u else Nothing -stixMapUniques :: (Unique -> Maybe StixTree) -> StixTree -> StixTree -stixMapUniques f t - = let qq = stixMapUniques f +stixExpr_MapUniques :: (Unique -> Maybe StixExpr) -> StixExpr -> StixExpr +stixExpr_MapUniques f t + = let qe = stixExpr_MapUniques f + qs = stixStmt_MapUniques f + qr = stixReg_MapUniques f in case t of - StReg reg - -> case reg of - StixMagicId mid -> t - StixTemp uu pr - -> case f uu of - Just xx -> xx - Nothing -> t - - StIndex pk t1 t2 -> StIndex pk (qq t1) (qq t2) - StInd pk t1 -> StInd pk (qq t1) - StAssign pk t1 t2 -> StAssign pk (qq t1) (qq t2) - StJump dsts t1 -> StJump dsts (qq t1) - StCondJump lbl t1 -> StCondJump lbl (qq t1) - StData pk ts -> StData pk (map qq ts) - StPrim op ts -> StPrim op (map qq ts) - StCall nm cconv pk ts -> StCall nm cconv pk (map qq ts) - - StSegment _ -> t + StReg reg -> case qr reg of + Nothing -> StReg reg + Just xx -> xx + StIndex pk t1 t2 -> StIndex pk (qe t1) (qe t2) + StInd pk t1 -> StInd pk (qe t1) + StMachOp mop args -> StMachOp mop (map qe args) + StCall nm cconv pk ts -> StCall nm cconv pk (map qe ts) StInt _ -> t StFloat _ -> t StDouble _ -> t StString _ -> t StCLbl _ -> t + +stixStmt_MapUniques :: (Unique -> Maybe StixExpr) -> StixStmt -> StixStmt +stixStmt_MapUniques f t + = let qe = stixExpr_MapUniques f + qs = stixStmt_MapUniques f + qr = stixReg_MapUniques f + qv = stixVReg_MapUniques f + + doMopLhss Just0 = Just0 + doMopLhss (Just1 r1) + = case qv r1 of + Nothing -> Just1 r1 + other -> doMopLhss_panic + doMopLhss (Just2 r1 r2) + = case (qv r1, qv r2) of + (Nothing, Nothing) -> Just2 r1 r2 + other -> doMopLhss_panic + -- Because the StixRegs processed by doMopLhss are lvalues, they + -- absolutely shouldn't be mapped to a StixExpr; + -- hence we panic if they do. Same deal for StAssignReg below. + doMopLhss_panic + = panic "stixStmt_MapUniques:doMopLhss" + in + case t of + StAssignReg pk reg rhs + -> case qr reg of + Nothing -> StAssignReg pk reg (qe rhs) + Just xx -> panic "stixStmt_MapUniques:StAssignReg" + StAssignMem pk addr rhs -> StAssignMem pk (qe addr) (qe rhs) + StJump dsts t1 -> StJump dsts (qe t1) + StCondJump lbl t1 -> StCondJump lbl (qe t1) + StData pk ts -> StData pk (map qe ts) + StVoidable expr -> StVoidable (qe expr) + StAssignMachOp lhss mop args + -> StAssignMachOp (doMopLhss lhss) mop (map qe args) + StSegment _ -> t StLabel _ -> t StFunBegin _ -> t StFunEnd _ -> t StFallThrough _ -> t - StScratchWord _ -> t StComment _ -> t + StDataString _ -> t + + +stixReg_MapUniques :: (Unique -> Maybe StixExpr) -> StixReg -> Maybe StixExpr +stixReg_MapUniques f reg + = case reg of + StixMagicId mid -> Nothing + StixTemp vreg -> stixVReg_MapUniques f vreg + +stixVReg_MapUniques :: (Unique -> Maybe StixExpr) -> StixVReg -> Maybe StixExpr +stixVReg_MapUniques f (StixVReg uu pr) + = f uu +\end{code} + +\begin{code} +-- Lift StStrings out of top-level StDatas, putting them at the end of +-- the block, and replacing them with StCLbls which refer to the lifted-out strings. +{- Motivation for this hackery provided by the following bug: + Stix: + (DataSegment) + Bogon.ping_closure : + (Data P_ Addr.A#_static_info) + (Data StgAddr (Str `alalal')) + (Data P_ (0)) + results in: + .data + .align 8 + .global Bogon_ping_closure + Bogon_ping_closure: + .long Addr_Azh_static_info + .long .Ln1a8 + .Ln1a8: + .byte 0x61 + .byte 0x6C + .byte 0x61 + .byte 0x6C + .byte 0x61 + .byte 0x6C + .byte 0x00 + .long 0 + ie, the Str is planted in-line, when what we really meant was to place + a _reference_ to the string there. liftStrings will lift out all such + strings in top-level data and place them at the end of the block. + + This is still a rather half-baked solution -- to do the job entirely right + would mean a complete traversal of all the Stixes, but there's currently no + real need for it, and it would be slow. Also, potentially there could be + literal types other than strings which need lifting out? +-} + +liftStrings :: [StixStmt] -> UniqSM [StixStmt] +liftStrings stmts + = liftStrings_wrk stmts [] [] + +liftStrings_wrk :: [StixStmt] -- originals + -> [StixStmt] -- (reverse) originals with strings lifted out + -> [(CLabel, FAST_STRING)] -- lifted strs, and their new labels + -> UniqSM [StixStmt] + +-- First, examine the original trees and lift out strings in top-level StDatas. +liftStrings_wrk (st:sts) acc_stix acc_strs + = case st of + StData sz datas + -> lift datas acc_strs `thenUs` \ (datas_done, acc_strs1) -> + liftStrings_wrk sts ((StData sz datas_done):acc_stix) acc_strs1 + other + -> liftStrings_wrk sts (other:acc_stix) acc_strs + where + -- Handle a top-level StData + lift [] acc_strs = returnUs ([], acc_strs) + lift (d:ds) acc_strs + = lift ds acc_strs `thenUs` \ (ds_done, acc_strs1) -> + case d of + StString s + -> getUniqueUs `thenUs` \ unq -> + let lbl = mkAsmTempLabel unq in + returnUs ((StCLbl lbl):ds_done, ((lbl,s):acc_strs1)) + other + -> returnUs (other:ds_done, acc_strs1) + +-- When we've run out of original trees, emit the lifted strings. +liftStrings_wrk [] acc_stix acc_strs + = returnUs (reverse acc_stix ++ concatMap f acc_strs) + where + f (lbl,str) = [StSegment RoDataSegment, + StLabel lbl, + StDataString str, + StSegment TextSegment] \end{code} +The NCG's monad. + \begin{code} data NatM_State = NatM_State UniqSupply Int type NatM result = NatM_State -> (result, NatM_State) diff --git a/ghc/compiler/nativeGen/StixInfo.lhs b/ghc/compiler/nativeGen/StixInfo.lhs index af6fa72af6..bf822e25fd 100644 --- a/ghc/compiler/nativeGen/StixInfo.lhs +++ b/ghc/compiler/nativeGen/StixInfo.lhs @@ -42,7 +42,7 @@ Generating code for info tables (arrays of data). \begin{code} genCodeInfoTable :: AbstractC - -> UniqSM StixTreeList + -> UniqSM StixStmtList genCodeInfoTable (CClosureInfoAndCode cl_info _ _ cl_descr) = returnUs (\xs -> StData PtrRep table : StLabel info_lbl : xs) @@ -106,7 +106,7 @@ genBitmapInfoTable -> C_SRT -> Int -> Bool -- must include SRT field (i.e. it's a vector) - -> UniqSM StixTreeList + -> UniqSM StixStmtList genBitmapInfoTable liveness srt closure_type include_srt = returnUs (\xs -> StData PtrRep table : xs) diff --git a/ghc/compiler/nativeGen/StixInteger.lhs b/ghc/compiler/nativeGen/StixInteger.lhs deleted file mode 100644 index cd642e8615..0000000000 --- a/ghc/compiler/nativeGen/StixInteger.lhs +++ /dev/null @@ -1,170 +0,0 @@ -% -% (c) The AQUA Project, Glasgow University, 1993-1998 -% - -\begin{code} -module StixInteger ( - gmpCompare, - gmpCompareInt, - gmpInteger2Int, - gmpInteger2Word, - gmpNegate - ) where - -#include "HsVersions.h" - -import {-# SOURCE #-} StixPrim ( amodeToStix ) - -import AbsCSyn hiding (spRel) -- bits and bobs.. -import ForeignCall ( CCallConv(..) ) -import PrimOp ( PrimOp(..) ) -import PrimRep ( PrimRep(..) ) -import Stix ( StixTree(..), StixTreeList, arrWordsHS ) -import UniqSupply ( returnUs, UniqSM ) -\end{code} - -Although gmpCompare doesn't allocate space, it does temporarily use -some space just beyond the heap pointer. This is safe, because the -enclosing routine has already guaranteed that this space will be -available. (See ``primOpHeapRequired.'') - -\begin{code} -stgArrWords__words :: StixTree -> StixTree -stgArrWords__BYTE_ARR_CTS :: StixTree -> StixTree - -stgArrWords__BYTE_ARR_CTS arr - = StIndex WordRep arr arrWordsHS -stgArrWords__words arr - = case arrWordsHS of - StInt i -> StInd WordRep (StIndex PtrRep arr (StInt (i-1))) - -gmpCompare - :: CAddrMode -- result (boolean) - -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode) - -- alloc hp + 2 arguments (2 parts each) - -> UniqSM StixTreeList - -gmpCompare res args@(csa1,cda1, csa2,cda2) - = let - result = amodeToStix res - sa1 = amodeToStix csa1 - sa2 = amodeToStix csa2 - aa1 = stgArrWords__words (amodeToStix cda1) - aa2 = stgArrWords__words (amodeToStix cda2) - da1 = stgArrWords__BYTE_ARR_CTS (amodeToStix cda1) - da2 = stgArrWords__BYTE_ARR_CTS (amodeToStix cda2) - - (a1,a2,a3) = toStruct scratch1 (aa1,sa1,da1) - (a4,a5,a6) = toStruct scratch2 (aa2,sa2,da2) - mpz_cmp = StCall SLIT("__gmpz_cmp") CCallConv IntRep [scratch1, scratch2] - r1 = StAssign IntRep result mpz_cmp - in - returnUs (\xs -> a1 : a2 : a3 : a4 : a5 : a6 : r1 : xs) - - -gmpCompareInt - :: CAddrMode -- result (boolean) - -> (CAddrMode,CAddrMode,CAddrMode) - -> UniqSM StixTreeList -- alloc hp + 1 arg (??) - -gmpCompareInt res args@(csa1,cda1, cai) - = let - result = amodeToStix res - sa1 = amodeToStix csa1 - aa1 = stgArrWords__words (amodeToStix cda1) - da1 = stgArrWords__BYTE_ARR_CTS (amodeToStix cda1) - ai = amodeToStix cai - (a1,a2,a3) = toStruct scratch1 (aa1,sa1,da1) - mpz_cmp_si = StCall SLIT("__gmpz_cmp_si") CCallConv IntRep [scratch1, ai] - r1 = StAssign IntRep result mpz_cmp_si - in - returnUs (\xs -> a1 : a2 : a3 : r1 : xs) -\end{code} - -\begin{code} -gmpInteger2Int - :: CAddrMode -- result - -> (CAddrMode,CAddrMode) -- alloc hp + argument (2 parts) - -> UniqSM StixTreeList - -gmpInteger2Int res args@(csa,cda) - = let - result = amodeToStix res - sa = amodeToStix csa - aa = stgArrWords__words (amodeToStix cda) - da = stgArrWords__BYTE_ARR_CTS (amodeToStix cda) - - (a1,a2,a3) = toStruct scratch1 (aa,sa,da) - mpz_get_si = StCall SLIT("__gmpz_get_si") CCallConv IntRep [scratch1] - r1 = StAssign IntRep result mpz_get_si - in - returnUs (\xs -> a1 : a2 : a3 : r1 : xs) - -gmpInteger2Word - :: CAddrMode -- result - -> (CAddrMode,CAddrMode) -- alloc hp + argument (2 parts) - -> UniqSM StixTreeList - -gmpInteger2Word res args@(csa,cda) - = let - result = amodeToStix res - sa = amodeToStix csa - aa = stgArrWords__words (amodeToStix cda) - da = stgArrWords__BYTE_ARR_CTS (amodeToStix cda) - - (a1,a2,a3) = toStruct scratch1 (aa,sa,da) - mpz_get_ui = StCall SLIT("__gmpz_get_ui") CCallConv IntRep [scratch1] - r1 = StAssign WordRep result mpz_get_ui - in - returnUs (\xs -> a1 : a2 : a3 : r1 : xs) - -gmpNegate - :: (CAddrMode,CAddrMode) -- result - -> (CAddrMode,CAddrMode) -- argument (2 parts) - -> UniqSM StixTreeList - -gmpNegate (rcs, rcd) args@(cs, cd) - = let - s = amodeToStix cs - a = stgArrWords__words (amodeToStix cd) - d = stgArrWords__BYTE_ARR_CTS (amodeToStix cd) - rs = amodeToStix rcs - ra = stgArrWords__words (amodeToStix rcd) - rd = stgArrWords__BYTE_ARR_CTS (amodeToStix rcd) - a1 = StAssign IntRep ra a - a2 = StAssign IntRep rs (StPrim IntNegOp [s]) - a3 = StAssign PtrRep rd d - in - returnUs (\xs -> a1 : a2 : a3 : xs) -\end{code} - -Support for the Gnu GMP multi-precision package. - -\begin{code} --- size (in words) of __MP_INT -mpIntSize = 3 :: Int - -mpAlloc, mpSize, mpData :: StixTree -> StixTree -mpAlloc base = StInd IntRep base -mpSize base = StInd IntRep (StIndex IntRep base (StInt 1)) -mpData base = StInd PtrRep (StIndex IntRep base (StInt 2)) -\end{code} - -\begin{code} -toStruct - :: StixTree - -> (StixTree, StixTree, StixTree) - -> (StixTree, StixTree, StixTree) - -toStruct str (alloc,size,arr) - = let - f1 = StAssign IntRep (mpAlloc str) alloc - f2 = StAssign IntRep (mpSize str) size - f3 = StAssign PtrRep (mpData str) arr - in - (f1, f2, f3) - -scratch1 = StScratchWord 0 -scratch2 = StScratchWord mpIntSize -\end{code} - diff --git a/ghc/compiler/nativeGen/StixMacro.lhs b/ghc/compiler/nativeGen/StixMacro.lhs index bcb2ba6a4b..170cc39ee0 100644 --- a/ghc/compiler/nativeGen/StixMacro.lhs +++ b/ghc/compiler/nativeGen/StixMacro.lhs @@ -11,13 +11,13 @@ module StixMacro ( macroCode, checkCode ) where import {-# SOURCE #-} StixPrim ( amodeToStix ) import MachRegs -import AbsCSyn ( CStmtMacro(..), CAddrMode, tagreg, - CCheckMacro(..) ) +import AbsCSyn ( CStmtMacro(..), CAddrMode, tagreg, CCheckMacro(..) ) import Constants ( uF_RET, uF_SU, uF_UPDATEE, uF_SIZE ) import ForeignCall ( CCallConv(..) ) -import PrimOp ( PrimOp(..) ) +import MachOp ( MachOp(..) ) import PrimRep ( PrimRep(..) ) import Stix +import Panic ( panic ) import UniqSupply ( returnUs, thenUs, UniqSM ) import CLabel ( mkBlackHoleInfoTableLabel, mkIndStaticInfoLabel, mkIndInfoLabel, mkUpdInfoLabel, mkSeqInfoLabel, @@ -33,7 +33,7 @@ closure address. macroCode :: CStmtMacro -- statement macro -> [CAddrMode] -- args - -> UniqSM StixTreeList + -> UniqSM StixStmtList \end{code} ----------------------------------------------------------------------------- @@ -44,18 +44,18 @@ macroCode ARGS_CHK_LOAD_NODE args = getUniqLabelNCG `thenUs` \ ulbl -> let [words, lbl] = map amodeToStix args - temp = StIndex PtrRep stgSp words - test = StPrim AddrGeOp [stgSu, temp] + temp = StIndex PtrRep (StReg stgSp) words + test = StMachOp MO_NatU_Ge [StReg stgSu, temp] cjmp = StCondJump ulbl test - assign = StAssign PtrRep stgNode lbl + assign = StAssignReg PtrRep stgNode lbl join = StLabel ulbl in returnUs (\xs -> cjmp : assign : updatePAP : join : xs) macroCode ARGS_CHK [words] = getUniqLabelNCG `thenUs` \ ulbl -> - let temp = StIndex PtrRep stgSp (amodeToStix words) - test = StPrim AddrGeOp [stgSu, temp] + let temp = StIndex PtrRep (StReg stgSp) (amodeToStix words) + test = StMachOp MO_NatU_Ge [StReg stgSu, temp] cjmp = StCondJump ulbl test join = StLabel ulbl in @@ -72,11 +72,9 @@ adding an indirection. macroCode UPD_CAF args = let [cafptr,bhptr] = map amodeToStix args - new_caf = StCall SLIT("newCAF") CCallConv VoidRep [cafptr] - w0 = StInd PtrRep cafptr - w1 = StInd PtrRep (StIndex PtrRep cafptr fixedHS) - a1 = StAssign PtrRep w1 bhptr - a2 = StAssign PtrRep w0 ind_static_info + new_caf = StVoidable (StCall SLIT("newCAF") CCallConv VoidRep [cafptr]) + a1 = StAssignMem PtrRep (StIndex PtrRep cafptr fixedHS) bhptr + a2 = StAssignMem PtrRep cafptr ind_static_info in returnUs (\xs -> new_caf : a1 : a2 : xs) \end{code} @@ -119,37 +117,35 @@ to the current Sp location. macroCode PUSH_UPD_FRAME args = let [bhptr, _{-0-}] = map amodeToStix args - frame n = StInd PtrRep - (StIndex PtrRep stgSp (StInt (toInteger (n-uF_SIZE)))) + frame n = StIndex PtrRep (StReg stgSp) (StInt (toInteger (n-uF_SIZE))) -- HWL: these values are *wrong* in a GranSim setup; ToDo: fix - a1 = StAssign PtrRep (frame uF_RET) upd_frame_info - a3 = StAssign PtrRep (frame uF_SU) stgSu - a4 = StAssign PtrRep (frame uF_UPDATEE) bhptr - - updSu = StAssign PtrRep stgSu - (StIndex PtrRep stgSp (StInt (toInteger (-uF_SIZE)))) + a1 = StAssignMem PtrRep (frame uF_RET) upd_frame_info + a3 = StAssignMem PtrRep (frame uF_SU) (StReg stgSu) + a4 = StAssignMem PtrRep (frame uF_UPDATEE) bhptr + + updSu = StAssignReg + PtrRep + stgSu + (StIndex PtrRep (StReg stgSp) (StInt (toInteger (-uF_SIZE)))) in returnUs (\xs -> a1 : a3 : a4 : updSu : xs) macroCode PUSH_SEQ_FRAME args = let [arg_frame] = map amodeToStix args - frame n = StInd PtrRep - (StIndex PtrRep arg_frame (StInt (toInteger n))) - a1 = StAssign PtrRep (frame 0) seq_frame_info - a2 = StAssign PtrRep (frame 1) stgSu - updSu = StAssign PtrRep stgSu arg_frame + frame n = StIndex PtrRep arg_frame (StInt (toInteger n)) + a1 = StAssignMem PtrRep (frame 0) seq_frame_info + a2 = StAssignMem PtrRep (frame 1) (StReg stgSu) + updSu = StAssignReg PtrRep stgSu arg_frame in returnUs (\xs -> a1 : a2 : updSu : xs) macroCode UPDATE_SU_FROM_UPD_FRAME args = let [arg_frame] = map amodeToStix args - frame n = StInd PtrRep - (StIndex PtrRep arg_frame (StInt (toInteger n))) - updSu - = StAssign PtrRep stgSu (frame uF_SU) + frame n = StIndex PtrRep arg_frame (StInt (toInteger n)) + updSu = StAssignReg PtrRep stgSu (StInd PtrRep (frame uF_SU)) in returnUs (\xs -> updSu : xs) \end{code} @@ -161,11 +157,12 @@ This one only applies if we have a machine register devoted to TagReg. \begin{code} macroCode SET_TAG [tag] - = let set_tag = StAssign IntRep stgTagReg (amodeToStix tag) - in - case stgReg tagreg of - Always _ -> returnUs id - Save _ -> returnUs (\ xs -> set_tag : xs) + = case get_MagicId_reg_or_addr tagreg of + Right baseRegAddr + -> returnUs id + Left realreg + -> let a1 = StAssignReg IntRep (StixMagicId tagreg) (amodeToStix tag) + in returnUs ( \xs -> a1 : xs ) \end{code} ----------------------------------------------------------------------------- @@ -173,24 +170,23 @@ macroCode SET_TAG [tag] \begin{code} macroCode REGISTER_IMPORT [arg] = returnUs ( - \xs -> StAssign WordRep (StInd WordRep stgSp) (amodeToStix arg) - : StAssign PtrRep stgSp (StPrim IntAddOp [stgSp, StInt 4]) + \xs -> StAssignMem WordRep (StReg stgSp) (amodeToStix arg) + : StAssignReg PtrRep stgSp (StMachOp MO_Nat_Add [StReg stgSp, StInt 4]) : xs ) macroCode REGISTER_FOREIGN_EXPORT [arg] = returnUs ( - \xs -> StCall SLIT("getStablePtr") CCallConv VoidRep [amodeToStix arg] + \xs -> StVoidable ( + StCall SLIT("getStablePtr") CCallConv VoidRep [amodeToStix arg] + ) : xs ) macroCode other args - = case other of - SET_TAG -> error "foobarxyzzy8" - _ -> error "StixMacro.macroCode: unknown macro/args" + = panic "StixMacro.macroCode" \end{code} - Do the business for a @HEAP_CHK@, having converted the args to Trees of StixOp. @@ -200,7 +196,7 @@ Let's make sure that these CAFs are lifted out, shall we? \begin{code} -- Some common labels -bh_info, ind_static_info, ind_info :: StixTree +bh_info, ind_static_info, ind_info :: StixExpr bh_info = StCLbl mkBlackHoleInfoTableLabel ind_static_info = StCLbl mkIndStaticInfoLabel @@ -208,37 +204,34 @@ ind_info = StCLbl mkIndInfoLabel upd_frame_info = StCLbl mkUpdInfoLabel seq_frame_info = StCLbl mkSeqInfoLabel -stg_update_PAP = regTableEntry CodePtrRep OFFSET_stgUpdatePAP - -- Some common call trees -updatePAP :: StixTree -updatePAP = StJump NoDestInfo stg_update_PAP +updatePAP :: StixStmt +updatePAP = mkStJump_to_RegTable_offw OFFSET_stgUpdatePAP + \end{code} ----------------------------------------------------------------------------- Heap/Stack checks \begin{code} -checkCode :: CCheckMacro -> [CAddrMode] -> StixTreeList -> UniqSM StixTreeList +checkCode :: CCheckMacro -> [CAddrMode] -> StixStmtList -> UniqSM StixStmtList checkCode macro args assts = getUniqLabelNCG `thenUs` \ ulbl_fail -> getUniqLabelNCG `thenUs` \ ulbl_pass -> - let args_stix = map amodeToStix args - newHp wds = StIndex PtrRep stgHp wds - assign_hp wds = StAssign PtrRep stgHp (newHp wds) - hp_alloc wds = StAssign IntRep stgHpAlloc wds - test_hp = StPrim AddrLeOp [stgHp, stgHpLim] - cjmp_hp = StCondJump ulbl_pass test_hp - - newSp wds = StIndex PtrRep stgSp (StPrim IntNegOp [wds]) - test_sp_pass wds = StPrim AddrGeOp [newSp wds, stgSpLim] - test_sp_fail wds = StPrim AddrLtOp [newSp wds, stgSpLim] + let args_stix = map amodeToStix args + newHp wds = StIndex PtrRep (StReg stgHp) wds + assign_hp wds = StAssignReg PtrRep stgHp (newHp wds) + hp_alloc wds = StAssignReg IntRep stgHpAlloc wds + test_hp = StMachOp MO_NatU_Le [StReg stgHp, StReg stgHpLim] + cjmp_hp = StCondJump ulbl_pass test_hp + newSp wds = StIndex PtrRep (StReg stgSp) (StMachOp MO_NatS_Neg [wds]) + test_sp_pass wds = StMachOp MO_NatU_Ge [newSp wds, StReg stgSpLim] + test_sp_fail wds = StMachOp MO_NatU_Lt [newSp wds, StReg stgSpLim] cjmp_sp_pass wds = StCondJump ulbl_pass (test_sp_pass wds) cjmp_sp_fail wds = StCondJump ulbl_fail (test_sp_fail wds) - - assign_ret r ret = StAssign CodePtrRep r ret + assign_ret r ret = mkStAssign CodePtrRep r ret fail = StLabel ulbl_fail join = StLabel ulbl_pass @@ -248,10 +241,10 @@ checkCode macro args assts = IF_ARCH_alpha(16383,65535) assign_liveness ptr_regs - = StAssign WordRep stgR9 - (StPrim XorOp [StInt aLL_NON_PTRS, ptr_regs]) + = StAssignReg WordRep stgR9 + (StMachOp MO_Nat_Xor [StInt aLL_NON_PTRS, ptr_regs]) assign_reentry reentry - = StAssign WordRep stgR10 reentry + = StAssignReg WordRep stgR10 reentry in returnUs ( @@ -340,28 +333,34 @@ checkCode macro args assts -- Various canned heap-check routines -mkStJump_to_GCentry :: String -> StixTree -mkStJump_to_GCentry gcname +mkStJump_to_GCentry_name :: String -> StixStmt +mkStJump_to_GCentry_name gcname -- | opt_Static = StJump NoDestInfo (StCLbl (mkRtsGCEntryLabel gcname)) -- | otherwise -- it's in a different DLL -- = StJump (StInd PtrRep (StLitLbl True sdoc)) -gc_chk (StInt 0) = StJump NoDestInfo (regTableEntry CodePtrRep OFFSET_stgChk0) -gc_chk (StInt 1) = StJump NoDestInfo (regTableEntry CodePtrRep OFFSET_stgChk1) -gc_chk (StInt n) = mkStJump_to_GCentry ("stg_chk_" ++ show n) - -gc_enter (StInt 1) = StJump NoDestInfo (regTableEntry CodePtrRep OFFSET_stgGCEnter1) -gc_enter (StInt n) = mkStJump_to_GCentry ("stg_gc_enter_" ++ show n) - -gc_seq (StInt n) = mkStJump_to_GCentry ("stg_gc_seq_" ++ show n) -gc_noregs = mkStJump_to_GCentry "stg_gc_noregs" -gc_unpt_r1 = mkStJump_to_GCentry "stg_gc_unpt_r1" -gc_unbx_r1 = mkStJump_to_GCentry "stg_gc_unbx_r1" -gc_f1 = mkStJump_to_GCentry "stg_gc_f1" -gc_d1 = mkStJump_to_GCentry "stg_gc_d1" -gc_gen = mkStJump_to_GCentry "stg_gen_chk" +mkStJump_to_RegTable_offw :: Int -> StixStmt +mkStJump_to_RegTable_offw regtable_offw +-- | opt_Static + = StJump NoDestInfo (StInd PtrRep (get_Regtable_addr_from_offset regtable_offw)) +-- | otherwise +-- do something plausible for cross-DLL jump + +gc_chk (StInt 0) = mkStJump_to_RegTable_offw OFFSET_stgChk0 +gc_chk (StInt 1) = mkStJump_to_RegTable_offw OFFSET_stgChk1 +gc_chk (StInt n) = mkStJump_to_GCentry_name ("stg_chk_" ++ show n) + +gc_enter (StInt 1) = mkStJump_to_RegTable_offw OFFSET_stgGCEnter1 +gc_enter (StInt n) = mkStJump_to_GCentry_name ("stg_gc_enter_" ++ show n) + +gc_seq (StInt n) = mkStJump_to_GCentry_name ("stg_gc_seq_" ++ show n) +gc_noregs = mkStJump_to_GCentry_name "stg_gc_noregs" +gc_unpt_r1 = mkStJump_to_GCentry_name "stg_gc_unpt_r1" +gc_unbx_r1 = mkStJump_to_GCentry_name "stg_gc_unbx_r1" +gc_f1 = mkStJump_to_GCentry_name "stg_gc_f1" +gc_d1 = mkStJump_to_GCentry_name "stg_gc_d1" +gc_gen = mkStJump_to_GCentry_name "stg_gen_chk" gc_ut (StInt p) (StInt np) - = mkStJump_to_GCentry ("stg_gc_ut_" ++ show p - ++ "_" ++ show np) + = mkStJump_to_GCentry_name ("stg_gc_ut_" ++ show p ++ "_" ++ show np) \end{code} diff --git a/ghc/compiler/nativeGen/StixPrim.hi-boot b/ghc/compiler/nativeGen/StixPrim.hi-boot index 1df7a8c364..7997542b8f 100644 --- a/ghc/compiler/nativeGen/StixPrim.hi-boot +++ b/ghc/compiler/nativeGen/StixPrim.hi-boot @@ -2,4 +2,4 @@ _interface_ StixPrim 1 _exports_ StixPrim amodeToStix; _declarations_ -1 amodeToStix _:_ AbsCSyn.CAddrMode -> Stix.StixTree ;; +1 amodeToStix _:_ AbsCSyn.CAddrMode -> Stix.StixExpr ;; diff --git a/ghc/compiler/nativeGen/StixPrim.hi-boot-5 b/ghc/compiler/nativeGen/StixPrim.hi-boot-5 index 6e86b28d39..f1b3b9e43c 100644 --- a/ghc/compiler/nativeGen/StixPrim.hi-boot-5 +++ b/ghc/compiler/nativeGen/StixPrim.hi-boot-5 @@ -1,3 +1,3 @@ __interface StixPrim 1 0 where __export StixPrim amodeToStix; -1 amodeToStix :: AbsCSyn.CAddrMode -> Stix.StixTree ; +1 amodeToStix :: AbsCSyn.CAddrMode -> Stix.StixExpr ; diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs index a7c04fec81..a94209c8be 100644 --- a/ghc/compiler/nativeGen/StixPrim.lhs +++ b/ghc/compiler/nativeGen/StixPrim.lhs @@ -3,20 +3,20 @@ % \begin{code} -module StixPrim ( primCode, amodeToStix, amodeToStix', foreignCallCode ) - where +module StixPrim ( amodeToStix, amodeToStix', foreignCallCode ) +where #include "HsVersions.h" import MachMisc import Stix -import StixInteger +import PprAbsC ( pprAmode ) import AbsCSyn hiding ( spRel ) import AbsCUtils ( getAmodeRep, mixedTypeLocn ) import SMRep ( fixedHdrSize ) import Literal ( Literal(..), word2IntLit ) -import PrimOp ( PrimOp(..) ) +import MachOp ( MachOp(..) ) import PrimRep ( PrimRep(..), getPrimRepSizeInBytes ) import UniqSupply ( returnUs, thenUs, getUniqueUs, UniqSM ) import Constants ( mIN_INTLIKE, mIN_CHARLIKE, uF_UPDATEE, bLOCK_SIZE, @@ -32,20 +32,14 @@ import FastTypes #include "NCG.h" \end{code} -The main honchos here are primCode anf foreignCallCode, which handle the guts of COpStmts. +The main honchos here are primCode and foreignCallCode, which handle the guts of COpStmts. \begin{code} foreignCallCode :: [CAddrMode] -- results -> ForeignCall -- op -> [CAddrMode] -- args - -> UniqSM StixTreeList - -primCode - :: [CAddrMode] -- results - -> PrimOp -- op - -> [CAddrMode] -- args - -> UniqSM StixTreeList + -> UniqSM StixStmtList \end{code} %************************************************************************ @@ -70,20 +64,23 @@ calling. \begin{code} foreignCallCode lhs (CCall (CCallSpec (StaticTarget fn) cconv safety)) rhs - | not (playSafe safety) = returnUs (\xs -> ccall : xs) + + | not (playSafe safety) + = returnUs (\xs -> ccall : xs) | otherwise = save_thread_state `thenUs` \ save -> load_thread_state `thenUs` \ load -> getUniqueUs `thenUs` \ uniq -> let - id = StReg (StixTemp uniq IntRep) + id = StixTemp (StixVReg uniq IntRep) - suspend = StAssign IntRep id - (StCall SLIT("suspendThread") {-no:cconv-} CCallConv - IntRep [stgBaseReg]) - resume = StCall SLIT("resumeThread") {-no:cconv-} CCallConv - VoidRep [id] + suspend = StAssignReg IntRep id + (StCall SLIT("suspendThread") {-no:cconv-} CCallConv + IntRep [StReg stgBaseReg]) + resume = StVoidable + (StCall SLIT("resumeThread") {-no:cconv-} CCallConv + VoidRep [StReg id]) in returnUs (\xs -> save (suspend : ccall : resume : load xs)) @@ -99,8 +96,8 @@ foreignCallCode lhs (CCall (CCallSpec (StaticTarget fn) cconv safety)) rhs _ -> base ccall = case lhs of - [] -> StCall fn cconv VoidRep args - [lhs] -> StAssign pk lhs' (StCall fn cconv pk args) + [] -> StVoidable (StCall fn cconv VoidRep args) + [lhs] -> mkStAssign pk lhs' (StCall fn cconv pk args) where lhs' = amodeToStix lhs pk = case getAmodeRep lhs of @@ -112,510 +109,24 @@ foreignCallCode lhs call rhs = ncgPrimopMoan "Native code generator can't handle foreign call" (ppr call) \end{code} - %************************************************************************ %* * -\subsubsection{Code for primops} +\subsubsection{Code for @CAddrMode@s} %* * %************************************************************************ -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 - -primCode [res] IntegerCmpOp args@[sa1,da1, sa2,da2] - = gmpCompare res (sa1,da1, sa2,da2) - -primCode [res] IntegerCmpIntOp args@[sa1,da1,ai] - = gmpCompareInt res (sa1,da1,ai) - -primCode [res] Integer2IntOp arg@[sa,da] - = gmpInteger2Int res (sa,da) - -primCode [res] Integer2WordOp arg@[sa,da] - = gmpInteger2Word res (sa,da) - -primCode [res] Int2WordOp [arg] - = simpleCoercion IntRep{-WordRep?-} res arg - -primCode [res] Word2IntOp [arg] - = simpleCoercion IntRep res arg - -primCode [res] AddrToHValueOp [arg] - = simpleCoercion PtrRep res arg - -#if (WORD_SIZE_IN_BITS == 32 || WORD_SIZE_IN_BITS == 64) -primCode [res] Int2AddrOp [arg] - = simpleCoercion AddrRep res arg - -primCode [res] Addr2IntOp [arg] - = simpleCoercion IntRep res arg -#endif - -primCode [res] Narrow8IntOp [arg] - = narrowingCoercion IntRep Int8Rep res arg -primCode [res] Narrow16IntOp [arg] - = narrowingCoercion IntRep Int16Rep res arg -primCode [res] Narrow32IntOp [arg] - = narrowingCoercion IntRep Int32Rep res arg - -primCode [res] Narrow8WordOp [arg] - = narrowingCoercion WordRep Word8Rep res arg -primCode [res] Narrow16WordOp [arg] - = narrowingCoercion WordRep Word16Rep res arg -primCode [res] Narrow32WordOp [arg] - = narrowingCoercion WordRep Word32Rep res arg -\end{code} - -\begin{code} -primCode [res] SameMutableArrayOp args - = let - compare = StPrim AddrEqOp (map amodeToStix args) - assign = StAssign IntRep (amodeToStix res) compare - in - returnUs (\xs -> assign : xs) - -primCode res@[_] SameMutableByteArrayOp args - = primCode res SameMutableArrayOp args - -primCode res@[_] SameMutVarOp args - = primCode res SameMutableArrayOp args -\end{code} - -\begin{code} -primCode res@[_] SameMVarOp args - = primCode res SameMutableArrayOp args - --- #define isEmptyMVarzh(r,a) \ --- r =(I_)((GET_INFO((StgMVar*)(a))) == &stg_EMPTY_MVAR_info ) -primCode [res] IsEmptyMVarOp [arg] - = let res' = amodeToStix res - arg' = amodeToStix arg - arg_info = StInd PtrRep arg' - em_info = StCLbl mkEMPTY_MVAR_infoLabel - same = StPrim IntEqOp [arg_info, em_info] - assign = StAssign IntRep res' same - in - returnUs (\xs -> assign : xs) - --- #define myThreadIdzh(t) (t = CurrentTSO) -primCode [res] MyThreadIdOp [] - = let res' = amodeToStix res - in returnUs (\xs -> StAssign ThreadIdRep res' stgCurrentTSO : xs) - -\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). - -\begin{code} - -primCode [lhs] UnsafeFreezeArrayOp [rhs] - = let - lhs' = amodeToStix lhs - rhs' = amodeToStix rhs - header = StInd PtrRep lhs' - assign = StAssign PtrRep lhs' rhs' - freeze = StAssign PtrRep header mutArrPtrsFrozen_info - in - returnUs (\xs -> assign : freeze : xs) - -primCode [lhs] UnsafeFreezeByteArrayOp [rhs] - = simpleCoercion PtrRep lhs rhs -\end{code} - -Returning the size of (mutable) byte arrays is just -an indexing operation. - -\begin{code} -primCode [lhs] SizeofByteArrayOp [rhs] - = let - lhs' = amodeToStix lhs - rhs' = amodeToStix rhs - sz = StIndex IntRep rhs' fixedHS - assign = StAssign IntRep lhs' (StInd IntRep sz) - in - returnUs (\xs -> assign : xs) - -primCode [lhs] SizeofMutableByteArrayOp [rhs] - = let - lhs' = amodeToStix lhs - rhs' = amodeToStix rhs - sz = StIndex IntRep rhs' fixedHS - assign = StAssign IntRep lhs' (StInd IntRep sz) - in - returnUs (\xs -> assign : xs) - -\end{code} - -Most other array primitives translate to simple indexing. - -\begin{code} -primCode lhs@[_] IndexArrayOp args - = primCode lhs ReadArrayOp args - -primCode [lhs] ReadArrayOp [obj, ix] - = let - lhs' = amodeToStix lhs - obj' = amodeToStix obj - ix' = amodeToStix ix - base = StIndex IntRep obj' arrPtrsHS - assign = StAssign PtrRep lhs' (StInd PtrRep (StIndex PtrRep base ix')) - in - returnUs (\xs -> assign : xs) - -primCode [] WriteArrayOp [obj, ix, v] - = let - obj' = amodeToStix obj - ix' = amodeToStix ix - v' = amodeToStix v - base = StIndex IntRep obj' arrPtrsHS - assign = StAssign PtrRep (StInd PtrRep (StIndex PtrRep base ix')) v' - in - returnUs (\xs -> assign : xs) - -primCode [] WriteForeignObjOp [obj, v] - = let - obj' = amodeToStix obj - v' = amodeToStix v - obj'' = StIndex AddrRep obj' (StInt 4711) -- fixedHS - assign = StAssign AddrRep (StInd AddrRep obj'') v' - in - returnUs (\xs -> assign : xs) - --- NB: indexing in "pk" units, *not* in bytes (WDP 95/09) -primCode ls IndexByteArrayOp_Char rs = primCode_ReadByteArrayOp Word8Rep ls rs -primCode ls IndexByteArrayOp_WideChar rs = primCode_ReadByteArrayOp CharRep ls rs -primCode ls IndexByteArrayOp_Int rs = primCode_ReadByteArrayOp IntRep ls rs -primCode ls IndexByteArrayOp_Word rs = primCode_ReadByteArrayOp WordRep ls rs -primCode ls IndexByteArrayOp_Addr rs = primCode_ReadByteArrayOp AddrRep ls rs -primCode ls IndexByteArrayOp_Float rs = primCode_ReadByteArrayOp FloatRep ls rs -primCode ls IndexByteArrayOp_Double rs = primCode_ReadByteArrayOp DoubleRep ls rs -primCode ls IndexByteArrayOp_StablePtr rs = primCode_ReadByteArrayOp StablePtrRep ls rs -primCode ls IndexByteArrayOp_Int8 rs = primCode_ReadByteArrayOp Int8Rep ls rs -primCode ls IndexByteArrayOp_Int16 rs = primCode_ReadByteArrayOp Int16Rep ls rs -primCode ls IndexByteArrayOp_Int32 rs = primCode_ReadByteArrayOp Int32Rep ls rs -primCode ls IndexByteArrayOp_Int64 rs = primCode_ReadByteArrayOp Int64Rep ls rs -primCode ls IndexByteArrayOp_Word8 rs = primCode_ReadByteArrayOp Word8Rep ls rs -primCode ls IndexByteArrayOp_Word16 rs = primCode_ReadByteArrayOp Word16Rep ls rs -primCode ls IndexByteArrayOp_Word32 rs = primCode_ReadByteArrayOp Word32Rep ls rs -primCode ls IndexByteArrayOp_Word64 rs = primCode_ReadByteArrayOp Word64Rep ls rs - -primCode ls ReadByteArrayOp_Char rs = primCode_ReadByteArrayOp Word8Rep ls rs -primCode ls ReadByteArrayOp_WideChar rs = primCode_ReadByteArrayOp CharRep ls rs -primCode ls ReadByteArrayOp_Int rs = primCode_ReadByteArrayOp IntRep ls rs -primCode ls ReadByteArrayOp_Word rs = primCode_ReadByteArrayOp WordRep ls rs -primCode ls ReadByteArrayOp_Addr rs = primCode_ReadByteArrayOp AddrRep ls rs -primCode ls ReadByteArrayOp_Float rs = primCode_ReadByteArrayOp FloatRep ls rs -primCode ls ReadByteArrayOp_Double rs = primCode_ReadByteArrayOp DoubleRep ls rs -primCode ls ReadByteArrayOp_StablePtr rs = primCode_ReadByteArrayOp StablePtrRep ls rs -primCode ls ReadByteArrayOp_Int8 rs = primCode_ReadByteArrayOp Int8Rep ls rs -primCode ls ReadByteArrayOp_Int16 rs = primCode_ReadByteArrayOp Int16Rep ls rs -primCode ls ReadByteArrayOp_Int32 rs = primCode_ReadByteArrayOp Int32Rep ls rs -primCode ls ReadByteArrayOp_Int64 rs = primCode_ReadByteArrayOp Int64Rep ls rs -primCode ls ReadByteArrayOp_Word8 rs = primCode_ReadByteArrayOp Word8Rep ls rs -primCode ls ReadByteArrayOp_Word16 rs = primCode_ReadByteArrayOp Word16Rep ls rs -primCode ls ReadByteArrayOp_Word32 rs = primCode_ReadByteArrayOp Word32Rep ls rs -primCode ls ReadByteArrayOp_Word64 rs = primCode_ReadByteArrayOp Word64Rep ls rs - -primCode ls WriteByteArrayOp_Char rs = primCode_WriteByteArrayOp Word8Rep ls rs -primCode ls WriteByteArrayOp_WideChar rs = primCode_WriteByteArrayOp CharRep ls rs -primCode ls WriteByteArrayOp_Int rs = primCode_WriteByteArrayOp IntRep ls rs -primCode ls WriteByteArrayOp_Word rs = primCode_WriteByteArrayOp WordRep ls rs -primCode ls WriteByteArrayOp_Addr rs = primCode_WriteByteArrayOp AddrRep ls rs -primCode ls WriteByteArrayOp_Float rs = primCode_WriteByteArrayOp FloatRep ls rs -primCode ls WriteByteArrayOp_Double rs = primCode_WriteByteArrayOp DoubleRep ls rs -primCode ls WriteByteArrayOp_StablePtr rs = primCode_WriteByteArrayOp StablePtrRep ls rs -primCode ls WriteByteArrayOp_Int8 rs = primCode_WriteByteArrayOp Int8Rep ls rs -primCode ls WriteByteArrayOp_Int16 rs = primCode_WriteByteArrayOp Int16Rep ls rs -primCode ls WriteByteArrayOp_Int32 rs = primCode_WriteByteArrayOp Int32Rep ls rs -primCode ls WriteByteArrayOp_Int64 rs = primCode_WriteByteArrayOp Int64Rep ls rs -primCode ls WriteByteArrayOp_Word8 rs = primCode_WriteByteArrayOp Word8Rep ls rs -primCode ls WriteByteArrayOp_Word16 rs = primCode_WriteByteArrayOp Word16Rep ls rs -primCode ls WriteByteArrayOp_Word32 rs = primCode_WriteByteArrayOp Word32Rep ls rs -primCode ls WriteByteArrayOp_Word64 rs = primCode_WriteByteArrayOp Word64Rep ls rs - -primCode ls IndexOffAddrOp_Char rs = primCode_IndexOffAddrOp Word8Rep ls rs -primCode ls IndexOffAddrOp_WideChar rs = primCode_IndexOffAddrOp CharRep ls rs -primCode ls IndexOffAddrOp_Int rs = primCode_IndexOffAddrOp IntRep ls rs -primCode ls IndexOffAddrOp_Word rs = primCode_IndexOffAddrOp WordRep ls rs -primCode ls IndexOffAddrOp_Addr rs = primCode_IndexOffAddrOp AddrRep ls rs -primCode ls IndexOffAddrOp_Float rs = primCode_IndexOffAddrOp FloatRep ls rs -primCode ls IndexOffAddrOp_Double rs = primCode_IndexOffAddrOp DoubleRep ls rs -primCode ls IndexOffAddrOp_StablePtr rs = primCode_IndexOffAddrOp StablePtrRep ls rs -primCode ls IndexOffAddrOp_Int8 rs = primCode_IndexOffAddrOp Int8Rep ls rs -primCode ls IndexOffAddrOp_Int16 rs = primCode_IndexOffAddrOp Int16Rep ls rs -primCode ls IndexOffAddrOp_Int32 rs = primCode_IndexOffAddrOp Int32Rep ls rs -primCode ls IndexOffAddrOp_Int64 rs = primCode_IndexOffAddrOp Int64Rep ls rs -primCode ls IndexOffAddrOp_Word8 rs = primCode_IndexOffAddrOp Word8Rep ls rs -primCode ls IndexOffAddrOp_Word16 rs = primCode_IndexOffAddrOp Word16Rep ls rs -primCode ls IndexOffAddrOp_Word32 rs = primCode_IndexOffAddrOp Word32Rep ls rs -primCode ls IndexOffAddrOp_Word64 rs = primCode_IndexOffAddrOp Word64Rep ls rs - -primCode ls IndexOffForeignObjOp_Char rs = primCode_IndexOffForeignObjOp Word8Rep ls rs -primCode ls IndexOffForeignObjOp_WideChar rs = primCode_IndexOffForeignObjOp CharRep ls rs -primCode ls IndexOffForeignObjOp_Int rs = primCode_IndexOffForeignObjOp IntRep ls rs -primCode ls IndexOffForeignObjOp_Word rs = primCode_IndexOffForeignObjOp WordRep ls rs -primCode ls IndexOffForeignObjOp_Addr rs = primCode_IndexOffForeignObjOp AddrRep ls rs -primCode ls IndexOffForeignObjOp_Float rs = primCode_IndexOffForeignObjOp FloatRep ls rs -primCode ls IndexOffForeignObjOp_Double rs = primCode_IndexOffForeignObjOp DoubleRep ls rs -primCode ls IndexOffForeignObjOp_StablePtr rs = primCode_IndexOffForeignObjOp StablePtrRep ls rs -primCode ls IndexOffForeignObjOp_Int8 rs = primCode_IndexOffForeignObjOp Int8Rep ls rs -primCode ls IndexOffForeignObjOp_Int16 rs = primCode_IndexOffForeignObjOp Int16Rep ls rs -primCode ls IndexOffForeignObjOp_Int32 rs = primCode_IndexOffForeignObjOp Int32Rep ls rs -primCode ls IndexOffForeignObjOp_Int64 rs = primCode_IndexOffForeignObjOp Int64Rep ls rs -primCode ls IndexOffForeignObjOp_Word8 rs = primCode_IndexOffForeignObjOp Word8Rep ls rs -primCode ls IndexOffForeignObjOp_Word16 rs = primCode_IndexOffForeignObjOp Word16Rep ls rs -primCode ls IndexOffForeignObjOp_Word32 rs = primCode_IndexOffForeignObjOp Word32Rep ls rs -primCode ls IndexOffForeignObjOp_Word64 rs = primCode_IndexOffForeignObjOp Word64Rep ls rs - -primCode ls ReadOffAddrOp_Char rs = primCode_IndexOffAddrOp Word8Rep ls rs -primCode ls ReadOffAddrOp_WideChar rs = primCode_IndexOffAddrOp CharRep ls rs -primCode ls ReadOffAddrOp_Int rs = primCode_IndexOffAddrOp IntRep ls rs -primCode ls ReadOffAddrOp_Word rs = primCode_IndexOffAddrOp WordRep ls rs -primCode ls ReadOffAddrOp_Addr rs = primCode_IndexOffAddrOp AddrRep ls rs -primCode ls ReadOffAddrOp_Float rs = primCode_IndexOffAddrOp FloatRep ls rs -primCode ls ReadOffAddrOp_Double rs = primCode_IndexOffAddrOp DoubleRep ls rs -primCode ls ReadOffAddrOp_StablePtr rs = primCode_IndexOffAddrOp StablePtrRep ls rs -primCode ls ReadOffAddrOp_Int8 rs = primCode_IndexOffAddrOp Int8Rep ls rs -primCode ls ReadOffAddrOp_Int16 rs = primCode_IndexOffAddrOp Int16Rep ls rs -primCode ls ReadOffAddrOp_Int32 rs = primCode_IndexOffAddrOp Int32Rep ls rs -primCode ls ReadOffAddrOp_Int64 rs = primCode_IndexOffAddrOp Int64Rep ls rs -primCode ls ReadOffAddrOp_Word8 rs = primCode_IndexOffAddrOp Word8Rep ls rs -primCode ls ReadOffAddrOp_Word16 rs = primCode_IndexOffAddrOp Word16Rep ls rs -primCode ls ReadOffAddrOp_Word32 rs = primCode_IndexOffAddrOp Word32Rep ls rs -primCode ls ReadOffAddrOp_Word64 rs = primCode_IndexOffAddrOp Word64Rep ls rs - -primCode ls WriteOffAddrOp_Char rs = primCode_WriteOffAddrOp Word8Rep ls rs -primCode ls WriteOffAddrOp_WideChar rs = primCode_WriteOffAddrOp CharRep ls rs -primCode ls WriteOffAddrOp_Int rs = primCode_WriteOffAddrOp IntRep ls rs -primCode ls WriteOffAddrOp_Word rs = primCode_WriteOffAddrOp WordRep ls rs -primCode ls WriteOffAddrOp_Addr rs = primCode_WriteOffAddrOp AddrRep ls rs -primCode ls WriteOffAddrOp_Float rs = primCode_WriteOffAddrOp FloatRep ls rs -primCode ls WriteOffAddrOp_Double rs = primCode_WriteOffAddrOp DoubleRep ls rs -primCode ls WriteOffAddrOp_StablePtr rs = primCode_WriteOffAddrOp StablePtrRep ls rs -primCode ls WriteOffAddrOp_Int8 rs = primCode_WriteOffAddrOp Int8Rep ls rs -primCode ls WriteOffAddrOp_Int16 rs = primCode_WriteOffAddrOp Int16Rep ls rs -primCode ls WriteOffAddrOp_Int32 rs = primCode_WriteOffAddrOp Int32Rep ls rs -primCode ls WriteOffAddrOp_Int64 rs = primCode_WriteOffAddrOp Int64Rep ls rs -primCode ls WriteOffAddrOp_Word8 rs = primCode_WriteOffAddrOp Word8Rep ls rs -primCode ls WriteOffAddrOp_Word16 rs = primCode_WriteOffAddrOp Word16Rep ls rs -primCode ls WriteOffAddrOp_Word32 rs = primCode_WriteOffAddrOp Word32Rep ls rs -primCode ls WriteOffAddrOp_Word64 rs = primCode_WriteOffAddrOp Word64Rep ls rs - -\end{code} - - -DataToTagOp won't work for 64-bit archs, as it is. - -\begin{code} -primCode [lhs] DataToTagOp [arg] - = let lhs' = amodeToStix lhs - arg' = amodeToStix arg - infoptr = StInd PtrRep arg' - word_32 = StInd WordRep (StIndex PtrRep infoptr (StInt (-1))) - masked_le32 = StPrim SrlOp [word_32, StInt 16] - masked_be32 = StPrim AndOp [word_32, StInt 65535] -#ifdef WORDS_BIGENDIAN - masked = masked_be32 -#else - masked = masked_le32 -#endif - assign = StAssign IntRep lhs' masked - in - returnUs (\xs -> assign : xs) -\end{code} - -MutVars are pretty simple. -#define writeMutVarzh(a,v) (P_)(((StgMutVar *)(a))->var)=(v) - -\begin{code} -primCode [] WriteMutVarOp [aa,vv] - = let aa_s = amodeToStix aa - vv_s = amodeToStix vv - var_field = StIndex PtrRep aa_s fixedHS - assign = StAssign PtrRep (StInd PtrRep var_field) vv_s - in - returnUs (\xs -> assign : xs) - -primCode [rr] ReadMutVarOp [aa] - = let aa_s = amodeToStix aa - rr_s = amodeToStix rr - var_field = StIndex PtrRep aa_s fixedHS - assign = StAssign PtrRep rr_s (StInd PtrRep var_field) - in - returnUs (\xs -> assign : xs) -\end{code} - -ForeignObj# primops. - -\begin{code} -primCode [rr] ForeignObjToAddrOp [fo] - = let code = StAssign AddrRep (amodeToStix rr) - (StInd AddrRep - (StIndex PtrRep (amodeToStix fo) fixedHS)) - in - returnUs (\xs -> code : xs) - -primCode [] TouchOp [_] = returnUs id -\end{code} - -Now the more mundane operations. - -\begin{code} -primCode lhs op rhs - = let - lhs' = map amodeToStix lhs - rhs' = map amodeToStix' rhs - pk = getAmodeRep (head lhs) - in - returnUs (\ xs -> simplePrim pk lhs' op rhs' : xs) -\end{code} - -Helper fns for some array ops. - -\begin{code} -primCode_ReadByteArrayOp pk [lhs] [obj, ix] - = let - lhs' = amodeToStix lhs - obj' = amodeToStix obj - ix' = amodeToStix ix - base = StIndex IntRep obj' arrWordsHS - assign = StAssign pk lhs' (StInd pk (StIndex pk base ix')) - in - returnUs (\xs -> assign : xs) - - -primCode_IndexOffAddrOp pk [lhs] [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) - - -primCode_IndexOffForeignObjOp pk [lhs] [obj, ix] - = let - lhs' = amodeToStix lhs - obj' = amodeToStix obj - ix' = amodeToStix ix - obj'' = StIndex AddrRep obj' fixedHS - assign = StAssign pk lhs' (StInd pk (StIndex pk obj'' ix')) - in - returnUs (\xs -> assign : xs) - - -primCode_WriteOffAddrOp pk [] [obj, ix, v] - = let - obj' = amodeToStix obj - ix' = amodeToStix ix - v' = amodeToStix v - assign = StAssign pk (StInd pk (StIndex pk obj' ix')) v' - in - returnUs (\xs -> assign : xs) - - -primCode_WriteByteArrayOp pk [] [obj, ix, v] - = let - obj' = amodeToStix obj - ix' = amodeToStix ix - v' = amodeToStix v - base = StIndex IntRep obj' arrWordsHS - assign = StAssign pk (StInd pk (StIndex pk base ix')) v' - in - returnUs (\xs -> assign : xs) - -\end{code} - -\begin{code} -simpleCoercion - :: PrimRep - -> CAddrMode - -> CAddrMode - -> UniqSM StixTreeList - -simpleCoercion pk lhs rhs - = returnUs (\xs -> StAssign pk (amodeToStix lhs) (amodeToStix rhs) : xs) - - --- Rewrite a narrowing coercion into a pair of shifts. -narrowingCoercion - :: PrimRep -> PrimRep - -> CAddrMode -> CAddrMode - -> UniqSM StixTreeList - -narrowingCoercion pks pkd dst src - | szd > szs - = panic "StixPrim.narrowingCoercion" - | szd == szs - = returnUs (\xs -> StAssign pkd dst' src' : xs) - | otherwise - = returnUs (\xs -> assign : xs) - where - szs = getPrimRepSizeInBytes pks - szd = getPrimRepSizeInBytes pkd - src' = amodeToStix src - dst' = amodeToStix dst - shift_amt = fromIntegral (8 * (szs - szd)) - - assign - = StAssign pkd dst' - (StPrim (if signed then ISraOp else SrlOp) - [StPrim SllOp [src', StInt shift_amt], - StInt shift_amt]) - signed - = case pkd of - Int8Rep -> True; Int16Rep -> True - Int32Rep -> True; Int64Rep -> True; IntRep -> True - Word8Rep -> False; Word16Rep -> False - Word32Rep -> False; Word64Rep -> False; WordRep -> False - other -> pprPanic "StixPrim.narrowingCoercion" (ppr pkd) -\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. - -\begin{code} -simplePrim - :: PrimRep -- Rep of first destination - -> [StixTree] -- Destinations - -> PrimOp - -> [StixTree] - -> StixTree -\end{code} - -Now look for something more conventional. - -\begin{code} -simplePrim pk [lhs] op rest = StAssign pk lhs (StPrim op rest) -simplePrim pk as op bs = ncgPrimopMoan "simplPrim(all targets)" (ppr op) -\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 amodes that might possibly need the extra cast. \begin{code} -amodeToStix, amodeToStix' :: CAddrMode -> StixTree +amodeToStix, amodeToStix' :: CAddrMode -> StixExpr amodeToStix'{-'-} am@(CVal rr CharRep) - | mixedTypeLocn am = StPrim ChrOp [amodeToStix am] - | otherwise = amodeToStix am - -amodeToStix' am = amodeToStix am + | mixedTypeLocn am = StMachOp MO_NatS_to_32U [amodeToStix am] + | otherwise = amodeToStix am +amodeToStix' am + = amodeToStix am ----------- amodeToStix am@(CVal rr CharRep) @@ -624,20 +135,22 @@ amodeToStix am@(CVal rr CharRep) amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr)) +amodeToStix (CMem pk addr) = StInd pk (amodeToStix addr) + amodeToStix (CAddr (SpRel off)) - = StIndex PtrRep stgSp (StInt (toInteger (iBox off))) + = StIndex PtrRep (StReg stgSp) (StInt (toInteger (iBox off))) amodeToStix (CAddr (HpRel off)) - = StIndex IntRep stgHp (StInt (toInteger (- (iBox off)))) + = StIndex IntRep (StReg stgHp) (StInt (toInteger (- (iBox off)))) amodeToStix (CAddr (NodeRel off)) - = StIndex IntRep stgNode (StInt (toInteger (iBox off))) + = StIndex IntRep (StReg stgNode) (StInt (toInteger (iBox off))) amodeToStix (CAddr (CIndex base off pk)) = StIndex pk (amodeToStix base) (amodeToStix off) amodeToStix (CReg magic) = StReg (StixMagicId magic) -amodeToStix (CTemp uniq pk) = StReg (StixTemp uniq pk) +amodeToStix (CTemp uniq pk) = StReg (StixTemp (StixVReg uniq pk)) amodeToStix (CLbl lbl _) = StCLbl lbl @@ -649,7 +162,7 @@ amodeToStix (CCharLike (CLit (MachChar c))) off = charLikeSize * (c - mIN_CHARLIKE) amodeToStix (CCharLike x) - = panic "CCharLike" + = panic "amodeToStix.CCharLike" amodeToStix (CIntLike (CLit (MachInt i))) = StIndex Word8Rep iNTLIKE_closure (StInt (toInteger off)) @@ -657,7 +170,7 @@ amodeToStix (CIntLike (CLit (MachInt i))) off = intLikeSize * (fromInteger (i - mIN_INTLIKE)) amodeToStix (CIntLike x) - = panic "CIntLike" + = panic "amodeToStix.CIntLike" amodeToStix (CLit core) = case core of @@ -678,12 +191,12 @@ amodeToStix (CMacroExpr _ macro [arg]) ARG_TAG -> amodeToStix arg -- just an integer no. of words GET_TAG -> #ifdef WORDS_BIGENDIAN - StPrim AndOp + StMachOp MO_Nat_And [StInd WordRep (StIndex PtrRep (amodeToStix arg) (StInt (toInteger (-1)))), StInt 65535] #else - StPrim SrlOp + StMachOp MO_Nat_Shr [StInd WordRep (StIndex PtrRep (amodeToStix arg) (StInt (toInteger (-1)))), StInt 16] @@ -692,8 +205,11 @@ amodeToStix (CMacroExpr _ macro [arg]) -> StInd PtrRep (StIndex PtrRep (amodeToStix arg) (StInt (toInteger uF_UPDATEE))) -litLitErr = - panic "native code generator can't compile lit-lits, use -fvia-C" +amodeToStix other + = pprPanic "StixPrim.amodeToStix" (pprAmode other) + +litLitErr + = ncgPrimopMoan "native code generator can't handle lit-lits" empty \end{code} Sizes of the CharLike and IntLike closures that are arranged as arrays @@ -702,12 +218,12 @@ in the data segment. (These are in bytes.) \begin{code} -- The INTLIKE base pointer -iNTLIKE_closure :: StixTree +iNTLIKE_closure :: StixExpr iNTLIKE_closure = StCLbl mkIntlikeClosureLabel -- The CHARLIKE base -cHARLIKE_closure :: StixTree +cHARLIKE_closure :: StixExpr cHARLIKE_closure = StCLbl mkCharlikeClosureLabel mutArrPtrsFrozen_info = StCLbl mkMAP_FROZEN_infoLabel @@ -720,55 +236,66 @@ intLikeSize = (fixedHdrSize + 1) * (sizeOf PtrRep) \begin{code} save_thread_state - = getUniqueUs `thenUs` \tso_uq -> - let tso = StReg (StixTemp tso_uq ThreadIdRep) in + = getUniqueUs `thenUs` \ tso_uq -> + let tso = StixTemp (StixVReg tso_uq ThreadIdRep) in returnUs (\xs -> - StAssign ThreadIdRep tso stgCurrentTSO : - StAssign PtrRep - (StInd PtrRep (StPrim IntAddOp - [tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))])) - stgSp : - StAssign PtrRep - (StInd PtrRep (StPrim IntAddOp - [tso, StInt (toInteger (TSO_SU*BYTES_PER_WORD))])) - stgSu : - StAssign PtrRep - (StInd PtrRep (StPrim IntAddOp - [stgCurrentNursery, - StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))])) - (StPrim IntAddOp [stgHp, StInt (toInteger (1 * BYTES_PER_WORD))]) : - xs + StAssignReg ThreadIdRep tso (StReg stgCurrentTSO) + : StAssignMem PtrRep + (StMachOp MO_Nat_Add + [StReg tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))]) + (StReg stgSp) + : StAssignMem PtrRep + (StMachOp MO_Nat_Add + [StReg tso, StInt (toInteger (TSO_SU*BYTES_PER_WORD))]) + (StReg stgSu) + : StAssignMem PtrRep + (StMachOp MO_Nat_Add + [StReg stgCurrentNursery, + StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))]) + (StMachOp MO_Nat_Add + [StReg stgHp, StInt (toInteger (1 * BYTES_PER_WORD))]) + : xs ) load_thread_state - = getUniqueUs `thenUs` \tso_uq -> - let tso = StReg (StixTemp tso_uq ThreadIdRep) in + = getUniqueUs `thenUs` \ tso_uq -> + let tso = StixTemp (StixVReg tso_uq ThreadIdRep) in returnUs (\xs -> - StAssign ThreadIdRep tso stgCurrentTSO : - StAssign PtrRep stgSp - (StInd PtrRep (StPrim IntAddOp - [tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))])) : - StAssign PtrRep stgSu - (StInd PtrRep (StPrim IntAddOp - [tso, StInt (toInteger (TSO_SU*BYTES_PER_WORD))])) : - StAssign PtrRep stgSpLim - (StPrim IntAddOp [tso, - StInt (toInteger ((TSO_STACK + rESERVED_STACK_WORDS) - *BYTES_PER_WORD))]) : - StAssign PtrRep stgHp - (StPrim IntSubOp [ - StInd PtrRep (StPrim IntAddOp - [stgCurrentNursery, - StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))]), - StInt (toInteger (1 * BYTES_PER_WORD)) - ]) : - StAssign PtrRep stgHpLim - (StPrim IntAddOp [ - StInd PtrRep (StPrim IntAddOp - [stgCurrentNursery, - StInt (toInteger (BDESCR_START * BYTES_PER_WORD))]), - StInt (toInteger (bLOCK_SIZE - (1 * BYTES_PER_WORD))) - ]) : - xs + StAssignReg ThreadIdRep tso (StReg stgCurrentTSO) + : StAssignReg PtrRep + stgSp + (StInd PtrRep + (StMachOp MO_Nat_Add + [StReg tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))])) + : StAssignReg PtrRep + stgSu + (StInd PtrRep + (StMachOp MO_Nat_Add + [StReg tso, StInt (toInteger (TSO_SU*BYTES_PER_WORD))])) + : StAssignReg PtrRep + stgSpLim + (StMachOp MO_Nat_Add + [StReg tso, + StInt (toInteger ((TSO_STACK + rESERVED_STACK_WORDS) + *BYTES_PER_WORD))]) + : StAssignReg PtrRep + stgHp + (StMachOp MO_Nat_Sub + [StInd PtrRep + (StMachOp MO_Nat_Add + [StReg stgCurrentNursery, + StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))]), + StInt (toInteger (1 * BYTES_PER_WORD)) + ]) + : StAssignReg PtrRep + stgHpLim + (StMachOp MO_Nat_Add + [StInd PtrRep + (StMachOp MO_Nat_Add + [StReg stgCurrentNursery, + StInt (toInteger (BDESCR_START * BYTES_PER_WORD))]), + StInt (toInteger (bLOCK_SIZE - (1 * BYTES_PER_WORD))) + ]) + : xs ) \end{code} diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index 6b7c199411..628e28ac1e 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -263,40 +263,6 @@ Invariants: stable name. -[Alastair Reid is to blame for this!] - -These days, (Glasgow) Haskell seems to have a bit of everything from -other languages: strict operations, mutable variables, sequencing, -pointers, etc. About the only thing left is LISP's ability to test -for pointer equality. So, let's add it in! - -\begin{verbatim} -reallyUnsafePtrEquality :: a -> a -> Int# -\end{verbatim} - -which tests any two closures (of the same type) to see if they're the -same. (Returns $0$ for @False@, $\neq 0$ for @True@ - to avoid -difficulties of trying to box up the result.) - -NB This is {\em really unsafe\/} because even something as trivial as -a garbage collection might change the answer by removing indirections. -Still, no-one's forcing you to use it. If you're worried about little -things like loss of referential transparency, you might like to wrap -it all up in a monad-like thing as John O'Donnell and John Hughes did -for non-determinism (1989 (Fraserburgh) Glasgow FP Workshop -Proceedings?) - -I'm thinking of using it to speed up a critical equality test in some -graphics stuff in a context where the possibility of saying that -denotationally equal things aren't isn't a problem (as long as it -doesn't happen too often.) ADR - -To Will: Jim said this was already in, but I can't see it so I'm -adding it. Up to you whether you add it. (Note that this could have -been readily implemented using a @veryDangerousCCall@ before they were -removed...) - - -- HWL: The first 4 Int# in all par... annotations denote: -- name, granularity info, size of result, degree of parallelism -- Same structure as _seq_ i.e. returns Int# diff --git a/ghc/compiler/prelude/PrimRep.lhs b/ghc/compiler/prelude/PrimRep.lhs index 96a093c28a..8054366f93 100644 --- a/ghc/compiler/prelude/PrimRep.lhs +++ b/ghc/compiler/prelude/PrimRep.lhs @@ -17,6 +17,7 @@ module PrimRep , is64BitRep , getPrimRepSize , getPrimRepSizeInBytes + , getPrimRepArrayElemSize , retPrimRepSize ) where @@ -193,7 +194,32 @@ getPrimRepSizeInBytes StablePtrRep = wORD_SIZE getPrimRepSizeInBytes StableNameRep = wORD_SIZE getPrimRepSizeInBytes ArrayRep = wORD_SIZE getPrimRepSizeInBytes ByteArrayRep = wORD_SIZE -getPrimRepSizeInBytes _ = panic "getPrimRepSize: ouch - this wasn't supposed to happen!" +getPrimRepSizeInBytes other = pprPanic "getPrimRepSizeInBytes" (ppr other) + + +-- Sizes in bytes of things when they are array elements, +-- so that we can generate the correct indexing code +-- inside the compiler. This is not the same as the above +-- getPrimRepSizeInBytes, the rationale behind which is +-- unclear to me. +getPrimRepArrayElemSize :: PrimRep -> Int +getPrimRepArrayElemSize PtrRep = wORD_SIZE +getPrimRepArrayElemSize IntRep = wORD_SIZE +getPrimRepArrayElemSize WordRep = wORD_SIZE +getPrimRepArrayElemSize AddrRep = wORD_SIZE +getPrimRepArrayElemSize StablePtrRep = wORD_SIZE +getPrimRepArrayElemSize ForeignObjRep = wORD_SIZE +getPrimRepArrayElemSize Word8Rep = 1 +getPrimRepArrayElemSize Word16Rep = 2 +getPrimRepArrayElemSize Word32Rep = 4 +getPrimRepArrayElemSize Word64Rep = 8 +getPrimRepArrayElemSize Int8Rep = 1 +getPrimRepArrayElemSize Int16Rep = 2 +getPrimRepArrayElemSize Int32Rep = 4 +getPrimRepArrayElemSize Int64Rep = 8 +getPrimRepArrayElemSize FloatRep = 4 +getPrimRepArrayElemSize DoubleRep = 8 +getPrimRepArrayElemSize other = pprPanic "getPrimRepSizeArrayElemSize" (ppr other) \end{code} diff --git a/ghc/compiler/prelude/primops.txt.pp b/ghc/compiler/prelude/primops.txt.pp index ee64b0568d..a8a80db016 100644 --- a/ghc/compiler/prelude/primops.txt.pp +++ b/ghc/compiler/prelude/primops.txt.pp @@ -1,5 +1,5 @@ ----------------------------------------------------------------------- --- $Id: primops.txt.pp,v 1.9 2001/10/31 17:03:12 rrt Exp $ +-- $Id: primops.txt.pp,v 1.10 2001/12/05 17:35:14 sewardj Exp $ -- -- Primitive Operations -- @@ -193,6 +193,8 @@ primop IntRemOp "remInt#" Dyadic with can_fail = True primop IntGcdOp "gcdInt#" Dyadic Int# -> Int# -> Int# + with out_of_line = True + primop IntNegOp "negateInt#" Monadic Int# -> Int# primop IntAddCOp "addIntC#" GenPrimOp Int# -> Int# -> (# Int#, Int# #) {Add with carry. First member of result is (wrapped) sum; second member is 0 iff no overflow occured.} @@ -383,7 +385,7 @@ primop IntegerGcdOp "gcdInteger#" GenPrimOp primop IntegerIntGcdOp "gcdIntegerInt#" GenPrimOp Int# -> ByteArr# -> Int# -> Int# {Greatest common divisor, where second argument is an ordinary Int\#.} - -- with commutable = True (surely not? APT 8/01) + with out_of_line = True primop IntegerDivExactOp "divExactInteger#" GenPrimOp Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #) @@ -404,12 +406,14 @@ primop IntegerCmpOp "cmpInteger#" GenPrimOp Int# -> ByteArr# -> Int# -> ByteArr# -> Int# {Returns -1,0,1 according as first argument is less than, equal to, or greater than second argument.} with needs_wrapper = True + out_of_line = True primop IntegerCmpIntOp "cmpIntegerInt#" GenPrimOp Int# -> ByteArr# -> Int# -> Int# {Returns -1,0,1 according as first argument is less than, equal to, or greater than second argument, which is an ordinary Int\#.} with needs_wrapper = True + out_of_line = True primop IntegerQuotRemOp "quotRemInteger#" GenPrimOp Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr#, Int#, ByteArr# #) @@ -427,10 +431,12 @@ primop IntegerDivModOp "divModInteger#" GenPrimOp primop Integer2IntOp "integer2Int#" GenPrimOp Int# -> ByteArr# -> Int# with needs_wrapper = True + out_of_line = True primop Integer2WordOp "integer2Word#" GenPrimOp Int# -> ByteArr# -> Word# with needs_wrapper = True + out_of_line = True #if WORD_SIZE_IN_BITS < 32 primop IntegerToInt32Op "integerToInt32#" GenPrimOp @@ -440,14 +446,6 @@ primop IntegerToWord32Op "integerToWord32#" GenPrimOp Int# -> ByteArr# -> Word32# #endif -#if WORD_SIZE_IN_BITS < 64 -primop IntegerToInt64Op "integerToInt64#" GenPrimOp - Int# -> ByteArr# -> Int64# - -primop IntegerToWord64Op "integerToWord64#" GenPrimOp - Int# -> ByteArr# -> Word64# -#endif - primop IntegerAndOp "andInteger#" GenPrimOp Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #) with out_of_line = True @@ -464,7 +462,7 @@ primop IntegerComplementOp "complementInteger#" GenPrimOp Int# -> ByteArr# -> (# Int#, ByteArr# #) with out_of_line = True -#endif /* ILX */ +#endif /* ndef ILX */ ------------------------------------------------------------------------ section "Double#" @@ -1355,7 +1353,7 @@ primop IsEmptyMVarOp "isEmptyMVar#" GenPrimOp {Return 1 if mvar is empty; 0 otherwise.} with usage = { mangle IsEmptyMVarOp [mkP, mkP] mkM } - + out_of_line = True ------------------------------------------------------------------------ section "Delay/wait operations" @@ -1414,7 +1412,9 @@ primop YieldOp "yield#" GenPrimOp out_of_line = True primop MyThreadIdOp "myThreadId#" GenPrimOp - State# RealWorld -> (# State# RealWorld, ThreadId# #) + State# RealWorld -> (# State# RealWorld, ThreadId# #) + with + out_of_line = True ------------------------------------------------------------------------ section "Weak pointers" @@ -1435,6 +1435,7 @@ primop DeRefWeakOp "deRefWeak#" GenPrimOp with usage = { mangle DeRefWeakOp [mkM, mkP] mkM } has_side_effects = True + out_of_line = True primop FinalizeWeakOp "finalizeWeak#" GenPrimOp Weak# a -> State# RealWorld -> (# State# RealWorld, Int#, @@ -1456,6 +1457,7 @@ primop MakeStablePtrOp "makeStablePtr#" GenPrimOp strictness = { \ arity -> StrictnessInfo [wwLazy, wwPrim] False } usage = { mangle MakeStablePtrOp [mkM, mkP] mkM } has_side_effects = True + out_of_line = True primop DeRefStablePtrOp "deRefStablePtr#" GenPrimOp StablePtr# a -> State# RealWorld -> (# State# RealWorld, a #) @@ -1463,6 +1465,7 @@ primop DeRefStablePtrOp "deRefStablePtr#" GenPrimOp usage = { mangle DeRefStablePtrOp [mkM, mkP] mkM } needs_wrapper = True has_side_effects = True + out_of_line = True primop EqStablePtrOp "eqStablePtr#" GenPrimOp StablePtr# a -> StablePtr# a -> Int# @@ -1490,16 +1493,6 @@ primop StableNameToIntOp "stableNameToInt#" GenPrimOp usage = { mangle StableNameToIntOp [mkP] mkR } ------------------------------------------------------------------------ -section "Unsafe pointer equality" --- (#1 Bad Guy: Alistair Reid :) ------------------------------------------------------------------------- - -primop ReallyUnsafePtrEqualityOp "reallyUnsafePtrEquality#" GenPrimOp - a -> a -> Int# - with - usage = { mangle ReallyUnsafePtrEqualityOp [mkZ, mkZ] mkR } - ------------------------------------------------------------------------- section "Parallelism" ------------------------------------------------------------------------ diff --git a/ghc/compiler/utils/Maybes.lhs b/ghc/compiler/utils/Maybes.lhs index 3f94d34621..1cb6aee05c 100644 --- a/ghc/compiler/utils/Maybes.lhs +++ b/ghc/compiler/utils/Maybes.lhs @@ -5,7 +5,7 @@ \begin{code} module Maybes ( - Maybe2(..), Maybe3(..), + Maybe012(..), maybe012ToList, MaybeErr(..), orElse, @@ -32,13 +32,16 @@ infixr 4 `orElse` %************************************************************************ %* * -\subsection[Maybe2,3 types]{The @Maybe2@ and @Maybe3@ types} +\subsection[Maybe012 type]{The @Maybe012@ type} %* * %************************************************************************ \begin{code} -data Maybe2 a b = Just2 a b | Nothing2 deriving (Eq,Show) -data Maybe3 a b c = Just3 a b c | Nothing3 deriving (Eq,Show) +data Maybe012 a = Just0 | Just1 a | Just2 a a deriving (Eq,Show) + +maybe012ToList Just0 = [] +maybe012ToList (Just1 x) = [x] +maybe012ToList (Just2 x y) = [x, y] \end{code} diff --git a/ghc/includes/PrimOps.h b/ghc/includes/PrimOps.h index c9b6697f16..e48f54bb55 100644 --- a/ghc/includes/PrimOps.h +++ b/ghc/includes/PrimOps.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: PrimOps.h,v 1.85 2001/11/21 20:27:18 sof Exp $ + * $Id: PrimOps.h,v 1.86 2001/12/05 17:35:14 sewardj Exp $ * * (c) The GHC Team, 1998-2000 * @@ -7,6 +7,13 @@ * * ---------------------------------------------------------------------------*/ +/* As of 5 Dec 01, this file no longer implements the primops, since they are + translated into standard C in compiler/absCSyn/AbsCUtils during the absC + flattening pass. Only {add,sub,mul}IntCzh remain untranslated. Most of + what is here is now EXTFUN_RTS declarations for the out-of-line primop + implementations which live in compiler/rts/PrimOps.hc. +*/ + #ifndef PRIMOPS_H #define PRIMOPS_H @@ -16,78 +23,6 @@ #error GHC C backend requires 32+-bit words #endif -/* ----------------------------------------------------------------------------- - Helpers for the bytecode linker. - -------------------------------------------------------------------------- */ - -#define addrToHValuezh(r,a) r=(P_)a - - -/* ----------------------------------------------------------------------------- - Comparison PrimOps. - -------------------------------------------------------------------------- */ - -#define gtCharzh(r,a,b) r=((C_)(a))> ((C_)(b)) -#define geCharzh(r,a,b) r=((C_)(a))>=((C_)(b)) -#define eqCharzh(r,a,b) r=((C_)(a))==((C_)(b)) -#define neCharzh(r,a,b) r=((C_)(a))!=((C_)(b)) -#define ltCharzh(r,a,b) r=((C_)(a))< ((C_)(b)) -#define leCharzh(r,a,b) r=((C_)(a))<=((C_)(b)) - -/* Int comparisons: >#, >=# etc */ -#define zgzh(r,a,b) r=((I_)(a))> ((I_)(b)) -#define zgzezh(r,a,b) r=((I_)(a))>=((I_)(b)) -#define zezezh(r,a,b) r=((I_)(a))==((I_)(b)) -#define zszezh(r,a,b) r=((I_)(a))!=((I_)(b)) -#define zlzh(r,a,b) r=((I_)(a))< ((I_)(b)) -#define zlzezh(r,a,b) r=((I_)(a))<=((I_)(b)) - -#define gtWordzh(r,a,b) r=((W_)(a))> ((W_)(b)) -#define geWordzh(r,a,b) r=((W_)(a))>=((W_)(b)) -#define eqWordzh(r,a,b) r=((W_)(a))==((W_)(b)) -#define neWordzh(r,a,b) r=((W_)(a))!=((W_)(b)) -#define ltWordzh(r,a,b) r=((W_)(a))< ((W_)(b)) -#define leWordzh(r,a,b) r=((W_)(a))<=((W_)(b)) - -#define gtAddrzh(r,a,b) r=((A_)(a))> ((A_)(b)) -#define geAddrzh(r,a,b) r=((A_)(a))>=((A_)(b)) -#define eqAddrzh(r,a,b) r=((A_)(a))==((A_)(b)) -#define neAddrzh(r,a,b) r=((A_)(a))!=((A_)(b)) -#define ltAddrzh(r,a,b) r=((A_)(a))< ((A_)(b)) -#define leAddrzh(r,a,b) r=((A_)(a))<=((A_)(b)) - -#define gtFloatzh(r,a,b) r=((StgFloat)(a))> ((StgFloat)(b)) -#define geFloatzh(r,a,b) r=((StgFloat)(a))>=((StgFloat)(b)) -#define eqFloatzh(r,a,b) r=((StgFloat)(a))==((StgFloat)(b)) -#define neFloatzh(r,a,b) r=((StgFloat)(a))!=((StgFloat)(b)) -#define ltFloatzh(r,a,b) r=((StgFloat)(a))< ((StgFloat)(b)) -#define leFloatzh(r,a,b) r=((StgFloat)(a))<=((StgFloat)(b)) - -/* Double comparisons: >##, >=## etc */ -#define zgzhzh(r,a,b) r=((StgDouble)(a))> ((StgDouble)(b)) -#define zgzezhzh(r,a,b) r=((StgDouble)(a))>=((StgDouble)(b)) -#define zezezhzh(r,a,b) r=((StgDouble)(a))==((StgDouble)(b)) -#define zszezhzh(r,a,b) r=((StgDouble)(a))!=((StgDouble)(b)) -#define zlzhzh(r,a,b) r=((StgDouble)(a))< ((StgDouble)(b)) -#define zlzezhzh(r,a,b) r=((StgDouble)(a))<=((StgDouble)(b)) - -/* ----------------------------------------------------------------------------- - Char# PrimOps. - -------------------------------------------------------------------------- */ - -#define ordzh(r,a) r=(I_)(a) -#define chrzh(r,a) r=(C_)(a) - -/* ----------------------------------------------------------------------------- - Int# PrimOps. - -------------------------------------------------------------------------- */ - -#define zpzh(r,a,b) r=((I_)(a))+((I_)(b)) -#define zmzh(r,a,b) r=((I_)(a))-((I_)(b)) -#define ztzh(r,a,b) r=((I_)(a))*((I_)(b)) -#define quotIntzh(r,a,b) r=((I_)(a))/((I_)(b)) -#define remIntzh(r,a,b) r=((I_)(a))%((I_)(b)) -#define negateIntzh(r,a) r=-((I_)(a)) /* ----------------------------------------------------------------------------- * Int operations with carry. @@ -193,260 +128,14 @@ typedef union { } #endif -/* ----------------------------------------------------------------------------- - Word# PrimOps. - -------------------------------------------------------------------------- */ - -#define plusWordzh(r,a,b) r=((W_)(a))+((W_)(b)) -#define minusWordzh(r,a,b) r=((W_)(a))-((W_)(b)) -#define timesWordzh(r,a,b) r=((W_)(a))*((W_)(b)) -#define quotWordzh(r,a,b) r=((W_)(a))/((W_)(b)) -#define remWordzh(r,a,b) r=((W_)(a))%((W_)(b)) - -#define andzh(r,a,b) r=((W_)(a))&((W_)(b)) -#define orzh(r,a,b) r=((W_)(a))|((W_)(b)) -#define xorzh(r,a,b) r=((W_)(a))^((W_)(b)) -#define notzh(r,a) r=~((W_)(a)) - -/* The extra tests below properly define the behaviour when shifting - * by offsets larger than the width of the value being shifted. Doing - * so is undefined in C (and in fact gives different answers depending - * on whether the operation is constant folded or not with gcc on x86!) - */ - -#define shiftLzh(r,a,b) r=(((I_)(b)) >= BITS_IN(W_)) ? 0 : ((W_)(a))<<((I_)(b)) -#define shiftRLzh(r,a,b) r=(((I_)(b)) >= BITS_IN(W_)) ? 0 : ((W_)(a))>>((I_)(b)) -#define iShiftLzh(r,a,b) r=(((I_)(b)) >= BITS_IN(W_)) ? 0 : ((W_)(a))<<((I_)(b)) -/* Right shifting of signed quantities is not portable in C, so - the behaviour you'll get from using these primops depends - on the whatever your C compiler is doing. ToDo: fix/document. -- sof 8/98 -*/ -#define iShiftRAzh(r,a,b) r=(((I_)(b)) >= BITS_IN(I_)) ? ((((I_)(a)) < 0) ? -1 : 0) : ((I_)(a))>>((I_)(b)) -#define iShiftRLzh(r,a,b) r=(((I_)(b)) >= BITS_IN(I_)) ? 0 : (I_)((W_)((I_)(a))>>((I_)(b))) - -#define int2Wordzh(r,a) r=(W_)((I_)(a)) -#define word2Intzh(r,a) r=(I_)((W_)(a)) - -/* ----------------------------------------------------------------------------- - Explicitly sized Int# and Word# PrimOps. - -------------------------------------------------------------------------- */ - -#define narrow8Intzh(r,a) r=(StgInt8)((I_)(a)) -#define narrow16Intzh(r,a) r=(StgInt16)((I_)(a)) -#define narrow32Intzh(r,a) r=(StgInt32)((I_)(a)) -#define narrow8Wordzh(r,a) r=(StgWord8)((W_)(a)) -#define narrow16Wordzh(r,a) r=(StgWord16)((W_)(a)) -#define narrow32Wordzh(r,a) r=(StgWord32)((W_)(a)) - -/* ----------------------------------------------------------------------------- - Addr# PrimOps. - -------------------------------------------------------------------------- */ - -#define nullAddrzh(r,i) r=(A_)(0) -#define plusAddrzh(r,a,i) r=((char *)(a)) + (i) -#define minusAddrzh(r,a,b) r=((char *)(a)) - ((char *)(b)) -#define remAddrzh(r,a,i) r=((W_)(a))%(i) -#define int2Addrzh(r,a) r=(A_)(a) -#define addr2Intzh(r,a) r=(I_)(a) - -#define readCharOffAddrzh(r,a,i) r=((StgWord8 *)(a))[i] -#define readWideCharOffAddrzh(r,a,i) r=((C_ *)(a))[i] -#define readIntOffAddrzh(r,a,i) r=((I_ *)(a))[i] -#define readWordOffAddrzh(r,a,i) r=((W_ *)(a))[i] -#define readAddrOffAddrzh(r,a,i) r=((PP_)(a))[i] -#define readFloatOffAddrzh(r,a,i) r=PK_FLT((P_) (((StgFloat *)(a)) + i)) -#define readDoubleOffAddrzh(r,a,i) r=PK_DBL((P_) (((StgDouble *)(a)) + i)) -#define readStablePtrOffAddrzh(r,a,i) r=((StgStablePtr *)(a))[i] -#define readInt8OffAddrzh(r,a,i) r=((StgInt8 *)(a))[i] -#define readInt16OffAddrzh(r,a,i) r=((StgInt16 *)(a))[i] -#define readWord8OffAddrzh(r,a,i) r=((StgWord8 *)(a))[i] -#define readWord16OffAddrzh(r,a,i) r=((StgWord16 *)(a))[i] -#define readInt32OffAddrzh(r,a,i) r=((StgInt32 *)(a))[i] -#define readWord32OffAddrzh(r,a,i) r=((StgWord32 *)(a))[i] -#ifdef SUPPORT_LONG_LONGS -#define readInt64OffAddrzh(r,a,i) r=((LI_ *)(a))[i] -#define readWord64OffAddrzh(r,a,i) r=((LW_ *)(a))[i] -#else -#define readInt64OffAddrzh(r,a,i) r=((I_ *)(a))[i] -#define readWord64OffAddrzh(r,a,i) r=((W_ *)(a))[i] -#endif - -#define writeCharOffAddrzh(a,i,v) ((StgWord8 *)(a))[i] = (v) -#define writeWideCharOffAddrzh(a,i,v) ((C_ *)(a))[i] = (v) -#define writeIntOffAddrzh(a,i,v) ((I_ *)(a))[i] = (v) -#define writeWordOffAddrzh(a,i,v) ((W_ *)(a))[i] = (v) -#define writeAddrOffAddrzh(a,i,v) ((PP_)(a))[i] = (v) -#define writeForeignObjOffAddrzh(a,i,v) ((PP_)(a))[i] = ForeignObj_CLOSURE_DATA(v) -#define writeFloatOffAddrzh(a,i,v) ASSIGN_FLT((P_) (((StgFloat *)(a)) + i),v) -#define writeDoubleOffAddrzh(a,i,v) ASSIGN_DBL((P_) (((StgDouble *)(a)) + i),v) -#define writeStablePtrOffAddrzh(a,i,v) ((StgStablePtr *)(a))[i] = (v) -#define writeInt8OffAddrzh(a,i,v) ((StgInt8 *)(a))[i] = (v) -#define writeInt16OffAddrzh(a,i,v) ((StgInt16 *)(a))[i] = (v) -#define writeInt32OffAddrzh(a,i,v) ((StgInt32 *)(a))[i] = (v) -#define writeWord8OffAddrzh(a,i,v) ((StgWord8 *)(a))[i] = (v) -#define writeWord16OffAddrzh(a,i,v) ((StgWord16 *)(a))[i] = (v) -#define writeWord32OffAddrzh(a,i,v) ((StgWord32 *)(a))[i] = (v) -#ifdef SUPPORT_LONG_LONGS -#define writeInt64OffAddrzh(a,i,v) ((LI_ *)(a))[i] = (v) -#define writeWord64OffAddrzh(a,i,v) ((LW_ *)(a))[i] = (v) -#else -#define writeInt64OffAddrzh(a,i,v) ((I_ *)(a))[i] = (v) -#define writeWord64OffAddrzh(a,i,v) ((W_ *)(a))[i] = (v) -#endif - -#define indexCharOffAddrzh(r,a,i) r=((StgWord8 *)(a))[i] -#define indexWideCharOffAddrzh(r,a,i) r=((C_ *)(a))[i] -#define indexIntOffAddrzh(r,a,i) r=((I_ *)(a))[i] -#define indexWordOffAddrzh(r,a,i) r=((W_ *)(a))[i] -#define indexAddrOffAddrzh(r,a,i) r=((PP_)(a))[i] -#define indexFloatOffAddrzh(r,a,i) r=PK_FLT((P_) (((StgFloat *)(a)) + i)) -#define indexDoubleOffAddrzh(r,a,i) r=PK_DBL((P_) (((StgDouble *)(a)) + i)) -#define indexStablePtrOffAddrzh(r,a,i) r=((StgStablePtr *)(a))[i] -#define indexInt8OffAddrzh(r,a,i) r=((StgInt8 *)(a))[i] -#define indexInt16OffAddrzh(r,a,i) r=((StgInt16 *)(a))[i] -#define indexInt32OffAddrzh(r,a,i) r=((StgInt32 *)(a))[i] -#define indexWord8OffAddrzh(r,a,i) r=((StgWord8 *)(a))[i] -#define indexWord16OffAddrzh(r,a,i) r=((StgWord16 *)(a))[i] -#define indexWord32OffAddrzh(r,a,i) r=((StgWord32 *)(a))[i] -#ifdef SUPPORT_LONG_LONGS -#define indexInt64OffAddrzh(r,a,i) r=((LI_ *)(a))[i] -#define indexWord64OffAddrzh(r,a,i) r=((LW_ *)(a))[i] -#else -#define indexInt64OffAddrzh(r,a,i) r=((I_ *)(a))[i] -#define indexWord64OffAddrzh(r,a,i) r=((W_ *)(a))[i] -#endif - -/* ----------------------------------------------------------------------------- - Float PrimOps. - -------------------------------------------------------------------------- */ - -#define plusFloatzh(r,a,b) r=((StgFloat)(a))+((StgFloat)(b)) -#define minusFloatzh(r,a,b) r=((StgFloat)(a))-((StgFloat)(b)) -#define timesFloatzh(r,a,b) r=((StgFloat)(a))*((StgFloat)(b)) -#define divideFloatzh(r,a,b) r=((StgFloat)(a))/((StgFloat)(b)) -#define negateFloatzh(r,a) r=-((StgFloat)(a)) - -#define int2Floatzh(r,a) r=(StgFloat)((I_)(a)) -#define float2Intzh(r,a) r=(I_)((StgFloat)(a)) - -#define expFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,exp,((StgFloat)(a))) -#define logFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,log,((StgFloat)(a))) -#define sqrtFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,sqrt,((StgFloat)(a))) -#define sinFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,sin,((StgFloat)(a))) -#define cosFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,cos,((StgFloat)(a))) -#define tanFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,tan,((StgFloat)(a))) -#define asinFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,asin,((StgFloat)(a))) -#define acosFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,acos,((StgFloat)(a))) -#define atanFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,atan,((StgFloat)(a))) -#define sinhFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,sinh,((StgFloat)(a))) -#define coshFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,cosh,((StgFloat)(a))) -#define tanhFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,tanh,((StgFloat)(a))) -#define powerFloatzh(r,a,b) r=(StgFloat) RET_PRIM_STGCALL2(StgDouble,pow,((StgFloat)(a)),((StgFloat)(b))) - -/* ----------------------------------------------------------------------------- - Double PrimOps. - -------------------------------------------------------------------------- */ - -#define zpzhzh(r,a,b) r=((StgDouble)(a))+((StgDouble)(b)) -#define zmzhzh(r,a,b) r=((StgDouble)(a))-((StgDouble)(b)) -#define ztzhzh(r,a,b) r=((StgDouble)(a))*((StgDouble)(b)) -#define zszhzh(r,a,b) r=((StgDouble)(a))/((StgDouble)(b)) -#define negateDoublezh(r,a) r=-((StgDouble)(a)) - -#define int2Doublezh(r,a) r=(StgDouble)((I_)(a)) -#define double2Intzh(r,a) r=(I_)((StgDouble)(a)) - -#define float2Doublezh(r,a) r=(StgDouble)((StgFloat)(a)) -#define double2Floatzh(r,a) r=(StgFloat)((StgDouble)(a)) - -#define expDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,exp,((StgDouble)(a))) -#define logDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,log,((StgDouble)(a))) -#define sqrtDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,sqrt,((StgDouble)(a))) -#define sinDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,sin,((StgDouble)(a))) -#define cosDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,cos,((StgDouble)(a))) -#define tanDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,tan,((StgDouble)(a))) -#define asinDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,asin,((StgDouble)(a))) -#define acosDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,acos,((StgDouble)(a))) -#define atanDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,atan,((StgDouble)(a))) -#define sinhDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,sinh,((StgDouble)(a))) -#define coshDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,cosh,((StgDouble)(a))) -#define tanhDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,tanh,((StgDouble)(a))) -/* Power: **## */ -#define ztztzhzh(r,a,b) r=(StgDouble) RET_PRIM_STGCALL2(StgDouble,pow,((StgDouble)(a)),((StgDouble)(b))) /* ----------------------------------------------------------------------------- Integer PrimOps. -------------------------------------------------------------------------- */ -/* We can do integer2Int and cmpInteger inline, since they don't need - * to allocate any memory. - * - * integer2Int# is now modular. - */ - -#define integer2Intzh(r, sa,da) \ -{ I_ s, res; \ - \ - s = (sa); \ - if (s == 0) \ - res = 0; \ - else { \ - res = ((mp_limb_t *) (BYTE_ARR_CTS(da)))[0]; \ - if (s < 0) res = -res; \ - } \ - (r) = res; \ -} - -#define integer2Wordzh(r, sa,da) \ -{ I_ s; \ - W_ res; \ - \ - s = (sa); \ - if (s == 0) \ - res = 0; \ - else { \ - res = ((mp_limb_t *) (BYTE_ARR_CTS(da)))[0]; \ - if (s < 0) res = -res; \ - } \ - (r) = res; \ -} - -#define cmpIntegerzh(r, s1,d1, s2,d2) \ -{ MP_INT arg1; \ - MP_INT arg2; \ - \ - arg1._mp_size = (s1); \ - arg1._mp_alloc= ((StgArrWords *)d1)->words; \ - arg1._mp_d = (mp_limb_t *) (BYTE_ARR_CTS(d1)); \ - arg2._mp_size = (s2); \ - arg2._mp_alloc= ((StgArrWords *)d2)->words; \ - arg2._mp_d = (mp_limb_t *) (BYTE_ARR_CTS(d2)); \ - \ - (r) = RET_PRIM_STGCALL2(I_,mpz_cmp,&arg1,&arg2); \ -} - -#define cmpIntegerIntzh(r, s,d, i) \ -{ MP_INT arg; \ - \ - arg._mp_size = (s); \ - arg._mp_alloc = ((StgArrWords *)d)->words; \ - arg._mp_d = (mp_limb_t *) (BYTE_ARR_CTS(d)); \ - \ - (r) = RET_PRIM_STGCALL2(I_,mpz_cmp_si,&arg,i); \ -} - /* NOTE: gcdIntzh and gcdIntegerIntzh work only for positive inputs! */ -/* mp_limb_t must be able to hold an StgInt for this to work properly */ -#define gcdIntzh(r,a,b) \ -{ mp_limb_t aa = (mp_limb_t)(a); \ - r = RET_STGCALL3(StgInt, mpn_gcd_1, (mp_limb_t *)(&aa), 1, (mp_limb_t)(b)); \ -} - -#define gcdIntegerIntzh(r,sa,a,b) \ - r = RET_STGCALL3(StgInt, mpn_gcd_1, (mp_limb_t *)(BYTE_ARR_CTS(a)), sa, b) - -/* The rest are all out-of-line: -------- */ +/* Some of these are out-of-line: -------- */ /* Integer arithmetic */ EXTFUN_RTS(plusIntegerzh_fast); @@ -459,6 +148,13 @@ EXTFUN_RTS(remIntegerzh_fast); EXTFUN_RTS(divExactIntegerzh_fast); EXTFUN_RTS(divModIntegerzh_fast); +EXTFUN_RTS(cmpIntegerIntzh_fast); +EXTFUN_RTS(cmpIntegerzh_fast); +EXTFUN_RTS(integer2Intzh_fast); +EXTFUN_RTS(integer2Wordzh_fast); +EXTFUN_RTS(gcdIntegerIntzh_fast); +EXTFUN_RTS(gcdIntzh_fast); + /* Conversions */ EXTFUN_RTS(int2Integerzh_fast); EXTFUN_RTS(word2Integerzh_fast); @@ -473,54 +169,18 @@ EXTFUN_RTS(orIntegerzh_fast); EXTFUN_RTS(xorIntegerzh_fast); EXTFUN_RTS(complementIntegerzh_fast); + /* ----------------------------------------------------------------------------- Word64 PrimOps. -------------------------------------------------------------------------- */ #ifdef SUPPORT_LONG_LONGS -#define integerToWord64zh(r,sa,da) \ -{ mp_limb_t* d; \ - I_ s; \ - StgWord64 res; \ - \ - d = (mp_limb_t *) (BYTE_ARR_CTS(da)); \ - s = (sa); \ - switch (s) { \ - case 0: res = 0; break; \ - case 1: res = d[0]; break; \ - case -1: res = -d[0]; break; \ - default: \ - res = d[0] + ((StgWord64) d[1] << (BITS_IN (mp_limb_t))); \ - if (s < 0) res = -res; \ - } \ - (r) = res; \ -} - -#define integerToInt64zh(r,sa,da) \ -{ mp_limb_t* d; \ - I_ s; \ - StgInt64 res; \ - \ - d = (mp_limb_t *) (BYTE_ARR_CTS(da)); \ - s = (sa); \ - switch (s) { \ - case 0: res = 0; break; \ - case 1: res = d[0]; break; \ - case -1: res = -d[0]; break; \ - default: \ - res = d[0] + ((StgWord64) d[1] << (BITS_IN (mp_limb_t))); \ - if (s < 0) res = -res; \ - } \ - (r) = res; \ -} - /* Conversions */ EXTFUN_RTS(int64ToIntegerzh_fast); EXTFUN_RTS(word64ToIntegerzh_fast); -/* The rest are (way!) out of line, implemented via C entry points. - */ +/* The rest are (way!) out of line, implemented in vanilla C. */ I_ stg_gtWord64 (StgWord64, StgWord64); I_ stg_geWord64 (StgWord64, StgWord64); I_ stg_eqWord64 (StgWord64, StgWord64); @@ -563,6 +223,10 @@ LW_ stg_int64ToWord64 (StgInt64); LW_ stg_wordToWord64 (StgWord); W_ stg_word64ToWord (StgWord64); LI_ stg_word64ToInt64 (StgWord64); + +LI_ stg_integerToInt64 (I_ sa, StgByteArray /* Really: mp_limb_t* */ da); +LW_ stg_integerToWord64 (I_ sa, StgByteArray /* Really: mp_limb_t* */ da); + #endif /* ----------------------------------------------------------------------------- @@ -588,115 +252,27 @@ LI_ stg_word64ToInt64 (StgWord64); #define PTRS_ARR_CTS(a) REAL_PTRS_ARR_CTS(a) #endif + extern I_ genSymZh(void); extern I_ resetGenSymZh(void); -/*--- everything except new*Array is done inline: */ - -#define sameMutableArrayzh(r,a,b) r=(I_)((a)==(b)) -#define sameMutableByteArrayzh(r,a,b) r=(I_)((a)==(b)) - -#define readArrayzh(r,a,i) r=((PP_) PTRS_ARR_CTS(a))[(i)] - -#define readCharArrayzh(r,a,i) indexCharOffAddrzh(r,BYTE_ARR_CTS(a),i) -#define readWideCharArrayzh(r,a,i) indexWideCharOffAddrzh(r,BYTE_ARR_CTS(a),i) -#define readIntArrayzh(r,a,i) indexIntOffAddrzh(r,BYTE_ARR_CTS(a),i) -#define readWordArrayzh(r,a,i) indexWordOffAddrzh(r,BYTE_ARR_CTS(a),i) -#define readAddrArrayzh(r,a,i) indexAddrOffAddrzh(r,BYTE_ARR_CTS(a),i) -#define readFloatArrayzh(r,a,i) indexFloatOffAddrzh(r,BYTE_ARR_CTS(a),i) -#define readDoubleArrayzh(r,a,i) indexDoubleOffAddrzh(r,BYTE_ARR_CTS(a),i) -#define readStablePtrArrayzh(r,a,i) indexStablePtrOffAddrzh(r,BYTE_ARR_CTS(a),i) -#define readInt8Arrayzh(r,a,i) indexInt8OffAddrzh(r,BYTE_ARR_CTS(a),i) -#define readInt16Arrayzh(r,a,i) indexInt16OffAddrzh(r,BYTE_ARR_CTS(a),i) -#define readInt32Arrayzh(r,a,i) indexInt32OffAddrzh(r,BYTE_ARR_CTS(a),i) -#define readWord8Arrayzh(r,a,i) indexWord8OffAddrzh(r,BYTE_ARR_CTS(a),i) -#define readWord16Arrayzh(r,a,i) indexWord16OffAddrzh(r,BYTE_ARR_CTS(a),i) -#define readWord32Arrayzh(r,a,i) indexWord32OffAddrzh(r,BYTE_ARR_CTS(a),i) -#define readInt64Arrayzh(r,a,i) indexInt64OffAddrzh(r,BYTE_ARR_CTS(a),i) -#define readWord64Arrayzh(r,a,i) indexWord64OffAddrzh(r,BYTE_ARR_CTS(a),i) - -/* result ("r") arg ignored in write macros! */ -#define writeArrayzh(a,i,v) ((PP_) PTRS_ARR_CTS(a))[(i)]=(v) - -#define writeCharArrayzh(a,i,v) writeCharOffAddrzh(BYTE_ARR_CTS(a),i,v) -#define writeWideCharArrayzh(a,i,v) writeWideCharOffAddrzh(BYTE_ARR_CTS(a),i,v) -#define writeIntArrayzh(a,i,v) writeIntOffAddrzh(BYTE_ARR_CTS(a),i,v) -#define writeWordArrayzh(a,i,v) writeWordOffAddrzh(BYTE_ARR_CTS(a),i,v) -#define writeAddrArrayzh(a,i,v) writeAddrOffAddrzh(BYTE_ARR_CTS(a),i,v) -#define writeFloatArrayzh(a,i,v) writeFloatOffAddrzh(BYTE_ARR_CTS(a),i,v) -#define writeDoubleArrayzh(a,i,v) writeDoubleOffAddrzh(BYTE_ARR_CTS(a),i,v) -#define writeStablePtrArrayzh(a,i,v) writeStablePtrOffAddrzh(BYTE_ARR_CTS(a),i,v) -#define writeInt8Arrayzh(a,i,v) writeInt8OffAddrzh(BYTE_ARR_CTS(a),i,v) -#define writeInt16Arrayzh(a,i,v) writeInt16OffAddrzh(BYTE_ARR_CTS(a),i,v) -#define writeInt32Arrayzh(a,i,v) writeInt32OffAddrzh(BYTE_ARR_CTS(a),i,v) -#define writeWord8Arrayzh(a,i,v) writeWord8OffAddrzh(BYTE_ARR_CTS(a),i,v) -#define writeWord16Arrayzh(a,i,v) writeWord16OffAddrzh(BYTE_ARR_CTS(a),i,v) -#define writeWord32Arrayzh(a,i,v) writeWord32OffAddrzh(BYTE_ARR_CTS(a),i,v) -#define writeInt64Arrayzh(a,i,v) writeInt64OffAddrzh(BYTE_ARR_CTS(a),i,v) -#define writeWord64Arrayzh(a,i,v) writeWord64OffAddrzh(BYTE_ARR_CTS(a),i,v) - -#define indexArrayzh(r,a,i) r=((PP_) PTRS_ARR_CTS(a))[(i)] - -#define indexCharArrayzh(r,a,i) indexCharOffAddrzh(r,BYTE_ARR_CTS(a),i) -#define indexWideCharArrayzh(r,a,i) indexWideCharOffAddrzh(r,BYTE_ARR_CTS(a),i) -#define indexIntArrayzh(r,a,i) indexIntOffAddrzh(r,BYTE_ARR_CTS(a),i) -#define indexWordArrayzh(r,a,i) indexWordOffAddrzh(r,BYTE_ARR_CTS(a),i) -#define indexAddrArrayzh(r,a,i) indexAddrOffAddrzh(r,BYTE_ARR_CTS(a),i) -#define indexFloatArrayzh(r,a,i) indexFloatOffAddrzh(r,BYTE_ARR_CTS(a),i) -#define indexDoubleArrayzh(r,a,i) indexDoubleOffAddrzh(r,BYTE_ARR_CTS(a),i) -#define indexStablePtrArrayzh(r,a,i) indexStablePtrOffAddrzh(r,BYTE_ARR_CTS(a),i) -#define indexInt8Arrayzh(r,a,i) indexInt8OffAddrzh(r,BYTE_ARR_CTS(a),i) -#define indexInt16Arrayzh(r,a,i) indexInt16OffAddrzh(r,BYTE_ARR_CTS(a),i) -#define indexInt32Arrayzh(r,a,i) indexInt32OffAddrzh(r,BYTE_ARR_CTS(a),i) -#define indexWord8Arrayzh(r,a,i) indexWord8OffAddrzh(r,BYTE_ARR_CTS(a),i) -#define indexWord16Arrayzh(r,a,i) indexWord16OffAddrzh(r,BYTE_ARR_CTS(a),i) -#define indexWord32Arrayzh(r,a,i) indexWord32OffAddrzh(r,BYTE_ARR_CTS(a),i) -#define indexInt64Arrayzh(r,a,i) indexInt64OffAddrzh(r,BYTE_ARR_CTS(a),i) -#define indexWord64Arrayzh(r,a,i) indexWord64OffAddrzh(r,BYTE_ARR_CTS(a),i) - -/* Freezing arrays-of-ptrs requires changing an info table, for the - benefit of the generational collector. It needs to scavenge mutable - objects, even if they are in old space. When they become immutable, - they can be removed from this scavenge list. */ - -#define unsafeFreezzeArrayzh(r,a) \ - { \ - SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN_info); \ - r = a; \ - } - -#define unsafeFreezzeByteArrayzh(r,a) r=(a) +/*--- Almost everything in line. */ EXTFUN_RTS(unsafeThawArrayzh_fast); - -#define sizzeofByteArrayzh(r,a) \ - r = (((StgArrWords *)(a))->words * sizeof(W_)) -#define sizzeofMutableByteArrayzh(r,a) \ - r = (((StgArrWords *)(a))->words * sizeof(W_)) - -/* and the out-of-line ones... */ - EXTFUN_RTS(newByteArrayzh_fast); EXTFUN_RTS(newPinnedByteArrayzh_fast); EXTFUN_RTS(newArrayzh_fast); -// Highly unsafe, for use with a pinned ByteArray -// being kept alive with touch# -#define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a) - -/* encoding and decoding of floats/doubles. */ - -/* We only support IEEE floating point format */ -#include "ieee-flpt.h" - /* The decode operations are out-of-line because they need to allocate * a byte array. */ + +/* We only support IEEE floating point formats. */ +#include "ieee-flpt.h" EXTFUN_RTS(decodeFloatzh_fast); EXTFUN_RTS(decodeDoublezh_fast); /* grimy low-level support functions defined in StgPrimFloat.c */ - extern StgDouble __encodeDouble (I_ size, StgByteArray arr, I_ e); extern StgDouble __int_encodeDouble (I_ j, I_ e); extern StgFloat __encodeFloat (I_ size, StgByteArray arr, I_ e); @@ -712,6 +288,7 @@ extern StgInt isFloatInfinite(StgFloat f); extern StgInt isFloatDenormalized(StgFloat f); extern StgInt isFloatNegativeZero(StgFloat f); + /* ----------------------------------------------------------------------------- Mutable variables @@ -720,25 +297,21 @@ extern StgInt isFloatNegativeZero(StgFloat f); EXTFUN_RTS(newMutVarzh_fast); -#define readMutVarzh(r,a) r=(P_)(((StgMutVar *)(a))->var) -#define writeMutVarzh(a,v) (P_)(((StgMutVar *)(a))->var)=(v) -#define sameMutVarzh(r,a,b) r=(I_)((a)==(b)) /* ----------------------------------------------------------------------------- MVar PrimOps. All out of line, because they either allocate or may block. -------------------------------------------------------------------------- */ -#define sameMVarzh(r,a,b) r=(I_)((a)==(b)) -/* Assume external decl of EMPTY_MVAR_info is in scope by now */ -#define isEmptyMVarzh(r,a) r=(I_)((GET_INFO((StgMVar*)(a))) == &stg_EMPTY_MVAR_info ) +EXTFUN_RTS(isEmptyMVarzh_fast); EXTFUN_RTS(newMVarzh_fast); EXTFUN_RTS(takeMVarzh_fast); EXTFUN_RTS(putMVarzh_fast); EXTFUN_RTS(tryTakeMVarzh_fast); EXTFUN_RTS(tryPutMVarzh_fast); + /* ----------------------------------------------------------------------------- Delay/Wait PrimOps -------------------------------------------------------------------------- */ @@ -747,6 +320,7 @@ EXTFUN_RTS(waitReadzh_fast); EXTFUN_RTS(waitWritezh_fast); EXTFUN_RTS(delayzh_fast); + /* ----------------------------------------------------------------------------- Primitive I/O, error-handling PrimOps -------------------------------------------------------------------------- */ @@ -756,27 +330,15 @@ EXTFUN_RTS(raisezh_fast); extern void stg_exit(I_ n) __attribute__ ((noreturn)); + /* ----------------------------------------------------------------------------- Stable Name / Stable Pointer PrimOps -------------------------------------------------------------------------- */ EXTFUN_RTS(makeStableNamezh_fast); +EXTFUN_RTS(makeStablePtrzh_fast); +EXTFUN_RTS(deRefStablePtrzh_fast); -#define stableNameToIntzh(r,s) (r = ((StgStableName *)s)->sn) - -#define eqStableNamezh(r,sn1,sn2) \ - (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn)) - -#define makeStablePtrzh(r,a) \ - r = RET_STGCALL1(StgStablePtr,getStablePtr,a) - -#define deRefStablePtrzh(r,sp) do { \ - ASSERT(stable_ptr_table[(StgWord)sp].ref > 0); \ - r = stable_ptr_table[(StgWord)sp].addr; \ -} while (0); - -#define eqStablePtrzh(r,sp1,sp2) \ - (r = ((StgWord)sp1 == (StgWord)sp2)) /* ----------------------------------------------------------------------------- Concurrency/Exception PrimOps. @@ -788,12 +350,51 @@ EXTFUN_RTS(killThreadzh_fast); EXTFUN_RTS(seqzh_fast); EXTFUN_RTS(blockAsyncExceptionszh_fast); EXTFUN_RTS(unblockAsyncExceptionszh_fast); - -#define myThreadIdzh(t) (t = CurrentTSO) +EXTFUN_RTS(myThreadIdzh_fast); extern int cmp_thread(const StgTSO *tso1, const StgTSO *tso2); extern int rts_getThreadId(const StgTSO *tso); + +/* ----------------------------------------------------------------------------- + Weak Pointer PrimOps. + -------------------------------------------------------------------------- */ + +EXTFUN_RTS(mkWeakzh_fast); +EXTFUN_RTS(finalizzeWeakzh_fast); +EXTFUN_RTS(deRefWeakzh_fast); + + +/* ----------------------------------------------------------------------------- + Foreign Object PrimOps. + -------------------------------------------------------------------------- */ + +EXTFUN_RTS(mkForeignObjzh_fast); + + +/* ----------------------------------------------------------------------------- + BCOs and BCO linkery + -------------------------------------------------------------------------- */ + +EXTFUN_RTS(newBCOzh_fast); +EXTFUN_RTS(mkApUpd0zh_fast); + + +/* ----------------------------------------------------------------------------- + Signal handling. Not really primops, but called directly from Haskell. + -------------------------------------------------------------------------- */ + +#define STG_SIG_DFL (-1) +#define STG_SIG_IGN (-2) +#define STG_SIG_ERR (-3) +#define STG_SIG_HAN (-4) + +extern StgInt stg_sig_install (StgInt, StgInt, StgStablePtr, sigset_t *); +#define stg_sig_default(sig,mask) stg_sig_install(sig,STG_SIG_DFL,0,(sigset_t *)mask) +#define stg_sig_ignore(sig,mask) stg_sig_install(sig,STG_SIG_IGN,0,(sigset_t *)mask) +#define stg_sig_catch(sig,ptr,mask) stg_sig_install(sig,STG_SIG_HAN,ptr,(sigset_t *)mask) + + /* ------------------------------------------------------------------------ Parallel PrimOps @@ -886,97 +487,4 @@ extern int rts_getThreadId(const StgTSO *tso); #define parzh(r,node) r = 1 #endif -/* ----------------------------------------------------------------------------- - Pointer equality - -------------------------------------------------------------------------- */ - -/* warning: extremely non-referentially transparent, need to hide in - an appropriate monad. - - ToDo: follow indirections. -*/ - -#define reallyUnsafePtrEqualityzh(r,a,b) r=((StgPtr)(a) == (StgPtr)(b)) - -/* ----------------------------------------------------------------------------- - Weak Pointer PrimOps. - -------------------------------------------------------------------------- */ - -EXTFUN_RTS(mkWeakzh_fast); -EXTFUN_RTS(finalizzeWeakzh_fast); - -#define deRefWeakzh(code,val,w) \ - if (((StgWeak *)w)->header.info == &stg_WEAK_info) { \ - code = 1; \ - val = (P_)((StgWeak *)w)->value; \ - } else { \ - code = 0; \ - val = (P_)w; \ - } - -#define sameWeakzh(w1,w2) ((w1)==(w2)) - - -/* ----------------------------------------------------------------------------- - Foreign Object PrimOps. - -------------------------------------------------------------------------- */ - -#define ForeignObj_CLOSURE_DATA(c) (((StgForeignObj *)c)->data) - -#define foreignObjToAddrzh(r,fo) r=ForeignObj_CLOSURE_DATA(fo) -#define touchzh(o) /* nothing */ - -EXTFUN_RTS(mkForeignObjzh_fast); - -#define writeForeignObjzh(res,datum) \ - (ForeignObj_CLOSURE_DATA(res) = (P_)(datum)) - -#define eqForeignObjzh(r,f1,f2) r=(f1)==(f2) -#define indexCharOffForeignObjzh(r,fo,i) indexCharOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i) -#define indexWideCharOffForeignObjzh(r,fo,i) indexWideCharOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i) -#define indexIntOffForeignObjzh(r,fo,i) indexIntOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i) -#define indexWordOffForeignObjzh(r,fo,i) indexWordOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i) -#define indexAddrOffForeignObjzh(r,fo,i) indexAddrOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i) -#define indexFloatOffForeignObjzh(r,fo,i) indexFloatOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i) -#define indexDoubleOffForeignObjzh(r,fo,i) indexDoubleOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i) -#define indexStablePtrOffForeignObjzh(r,fo,i) indexStablePtrOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i) -#define indexInt8OffForeignObjzh(r,fo,i) indexInt8OffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i) -#define indexInt16OffForeignObjzh(r,fo,i) indexInt16OffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i) -#define indexInt32OffForeignObjzh(r,fo,i) indexInt32OffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i) -#define indexWord8OffForeignObjzh(r,fo,i) indexWord8OffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i) -#define indexWord16OffForeignObjzh(r,fo,i) indexWord16OffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i) -#define indexWord32OffForeignObjzh(r,fo,i) indexWord32OffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i) -#define indexInt64OffForeignObjzh(r,fo,i) indexInt64OffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i) -#define indexWord64OffForeignObjzh(r,fo,i) indexWord64OffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i) - -/* ----------------------------------------------------------------------------- - Constructor tags - -------------------------------------------------------------------------- */ - -#define dataToTagzh(r,a) r=(GET_TAG(((StgClosure *)a)->header.info)) - -/* tagToEnum# is handled directly by the code generator. */ - -/* ----------------------------------------------------------------------------- - BCOs and BCO linkery - -------------------------------------------------------------------------- */ - -EXTFUN_RTS(newBCOzh_fast); -EXTFUN_RTS(mkApUpd0zh_fast); - -/* ----------------------------------------------------------------------------- - Signal processing. Not really primops, but called directly from - Haskell. - -------------------------------------------------------------------------- */ - -#define STG_SIG_DFL (-1) -#define STG_SIG_IGN (-2) -#define STG_SIG_ERR (-3) -#define STG_SIG_HAN (-4) - -extern StgInt stg_sig_install (StgInt, StgInt, StgStablePtr, sigset_t *); -#define stg_sig_default(sig,mask) stg_sig_install(sig,STG_SIG_DFL,0,(sigset_t *)mask) -#define stg_sig_ignore(sig,mask) stg_sig_install(sig,STG_SIG_IGN,0,(sigset_t *)mask) -#define stg_sig_catch(sig,ptr,mask) stg_sig_install(sig,STG_SIG_HAN,ptr,(sigset_t *)mask) - #endif /* PRIMOPS_H */ diff --git a/ghc/includes/Stg.h b/ghc/includes/Stg.h index f6a74dfd73..f2140ca106 100644 --- a/ghc/includes/Stg.h +++ b/ghc/includes/Stg.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: Stg.h,v 1.42 2001/11/26 16:54:22 simonmar Exp $ + * $Id: Stg.h,v 1.43 2001/12/05 17:35:14 sewardj Exp $ * * (c) The GHC Team, 1998-1999 * @@ -217,6 +217,7 @@ typedef StgWord64 LW_; #include "StgTicky.h" #include "CCall.h" #include "Stable.h" +#include "PrimOpHelpers.h" /* Built-in entry points */ #include "StgMiscClosures.h" diff --git a/ghc/lib/std/PrelGHC.hi-boot.pp b/ghc/lib/std/PrelGHC.hi-boot.pp index d478480cea..d9ae78120b 100644 --- a/ghc/lib/std/PrelGHC.hi-boot.pp +++ b/ghc/lib/std/PrelGHC.hi-boot.pp @@ -238,8 +238,6 @@ __export PrelGHC word32ToIntegerzh #endif #if WORD_SIZE_IN_BITS < 64 - integerToInt64zh - integerToWord64zh int64ToIntegerzh word64ToIntegerzh #endif @@ -422,8 +420,6 @@ __export PrelGHC eqStableNamezh stableNameToIntzh - reallyUnsafePtrEqualityzh - newBCOzh BCOzh mkApUpd0zh diff --git a/ghc/lib/std/PrelInt.lhs b/ghc/lib/std/PrelInt.lhs index e28271685b..13f7c4a391 100644 --- a/ghc/lib/std/PrelInt.lhs +++ b/ghc/lib/std/PrelInt.lhs @@ -648,6 +648,8 @@ foreign import "stg_iShiftRA64" unsafe iShiftRA64# :: Int64# -> Int# -> In foreign import "stg_shiftL64" unsafe shiftL64# :: Word64# -> Int# -> Word64# foreign import "stg_shiftRL64" unsafe shiftRL64# :: Word64# -> Int# -> Word64# +foreign import "stg_integerToInt64" unsafe integerToInt64# :: Int# -> ByteArray# -> Int64# + {-# RULES "fromIntegral/Int->Int64" fromIntegral = \(I# x#) -> I64# (intToInt64# x#) "fromIntegral/Word->Int64" fromIntegral = \(W# x#) -> I64# (word64ToInt64# (wordToWord64# x#)) diff --git a/ghc/lib/std/PrelWord.lhs b/ghc/lib/std/PrelWord.lhs index fb12ea1186..30af9fcd20 100644 --- a/ghc/lib/std/PrelWord.lhs +++ b/ghc/lib/std/PrelWord.lhs @@ -746,6 +746,9 @@ foreign import "stg_not64" unsafe not64# :: Word64# -> Word64# foreign import "stg_shiftL64" unsafe shiftL64# :: Word64# -> Int# -> Word64# foreign import "stg_shiftRL64" unsafe shiftRL64# :: Word64# -> Int# -> Word64# +foreign import "stg_integerToWord64" unsafe integerToWord64# :: Int# -> ByteArray# -> Word64# + + {-# RULES "fromIntegral/Int->Word64" fromIntegral = \(I# x#) -> W64# (int64ToWord64# (intToInt64# x#)) "fromIntegral/Word->Word64" fromIntegral = \(W# x#) -> W64# (wordToWord64# x#) diff --git a/ghc/lib/std/cbits/longlong.c b/ghc/lib/std/cbits/longlong.c index 5a7bd55108..fdc7603bde 100644 --- a/ghc/lib/std/cbits/longlong.c +++ b/ghc/lib/std/cbits/longlong.c @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: longlong.c,v 1.3 2001/07/23 15:11:55 simonmar Exp $ + * $Id: longlong.c,v 1.4 2001/12/05 17:35:15 sewardj Exp $ * * (c) The GHC Team, 1998-1999 * @@ -74,8 +74,8 @@ StgInt64 stg_iShiftRA64 (StgInt64 a, StgInt b) {return a >> b;} StgInt64 stg_iShiftRL64 (StgInt64 a, StgInt b) {return (StgInt64) ((StgWord64) a >> b);} -/* Casting between longs and longer longs: - (the primops that cast between Integers and long longs are +/* Casting between longs and longer longs. + (the primops that cast from long longs to Integers expressed as macros, since these may cause some heap allocation). */ @@ -86,4 +86,40 @@ StgWord64 stg_wordToWord64 (StgWord w) {return (StgWord64) w;} StgWord stg_word64ToWord (StgWord64 w) {return (StgWord) w;} StgInt64 stg_word64ToInt64 (StgWord64 w) {return (StgInt64) w;} +StgWord64 stg_integerToWord64 (I_ sa, StgByteArray /* Really: mp_limb_t* */ da) +{ + mp_limb_t* d; + I_ s; + StgWord64 res; + d = (mp_limb_t *)da; + s = sa; + switch (s) { + case 0: res = 0; break; + case 1: res = d[0]; break; + case -1: res = -d[0]; break; + default: + res = d[0] + ((StgWord64) d[1] << (BITS_IN (mp_limb_t))); + if (s < 0) res = -res; + } + return res; +} + +StgInt64 stg_integerToInt64 (StgInt sa, StgByteArray /* Really: mp_limb_t* */ da) +{ + mp_limb_t* d; + I_ s; + StgInt64 res; + d = (mp_limb_t *)da; + s = (sa); + switch (s) { + case 0: res = 0; break; + case 1: res = d[0]; break; + case -1: res = -d[0]; break; + default: + res = d[0] + ((StgWord64) d[1] << (BITS_IN (mp_limb_t))); + if (s < 0) res = -res; + } + return res; +} + #endif /* SUPPORT_LONG_LONGS */ diff --git a/ghc/rts/Exception.hc b/ghc/rts/Exception.hc index 8cb24e9b75..817d6c2c5b 100644 --- a/ghc/rts/Exception.hc +++ b/ghc/rts/Exception.hc @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: Exception.hc,v 1.22 2001/11/22 14:25:12 simonmar Exp $ + * $Id: Exception.hc,v 1.23 2001/12/05 17:35:15 sewardj Exp $ * * (c) The GHC Team, 1998-2000 * @@ -212,6 +212,17 @@ FN_(killThreadzh_fast) FE_ } + +FN_(myThreadIdzh_fast) +{ + /* no args. */ + FB_ + R1.p = (P_)CurrentTSO; + JMP_(ENTRY_CODE(Sp[0])); + FE_ +} + + /* ----------------------------------------------------------------------------- Catch frames -------------------------------------------------------------------------- */ diff --git a/ghc/rts/PrimOps.hc b/ghc/rts/PrimOps.hc index 2036768e85..46ad653462 100644 --- a/ghc/rts/PrimOps.hc +++ b/ghc/rts/PrimOps.hc @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: PrimOps.hc,v 1.85 2001/11/22 14:25:12 simonmar Exp $ + * $Id: PrimOps.hc,v 1.86 2001/12/05 17:35:15 sewardj Exp $ * * (c) The GHC Team, 1998-2000 * @@ -329,7 +329,6 @@ FN_(newMutVarzh_fast) /* ----------------------------------------------------------------------------- Foreign Object Primitives - -------------------------------------------------------------------------- */ FN_(mkForeignObjzh_fast) @@ -451,6 +450,25 @@ FN_(finalizzeWeakzh_fast) FE_ } +FN_(deRefWeakzh_fast) +{ + /* R1.p = weak ptr */ + StgWeak* w; + I_ code; + P_ val; + FB_ + w = (StgWeak*)R1.p; + if (w->header.info == &stg_WEAK_info) { + code = 1; + val = (P_)((StgWeak *)w)->value; + } else { + code = 0; + val = (P_)w; + } + RET_NP(code,val); + FE_ +} + /* ----------------------------------------------------------------------------- Arbitrary-precision Integer operations. -------------------------------------------------------------------------- */ @@ -751,6 +769,97 @@ GMP_TAKE1_RET1(complementIntegerzh_fast, mpz_com); GMP_TAKE2_RET2(quotRemIntegerzh_fast, mpz_tdiv_qr); GMP_TAKE2_RET2(divModIntegerzh_fast, mpz_fdiv_qr); + +FN_(gcdIntzh_fast) +{ + /* R1 = the first Int#; R2 = the second Int# */ + mp_limb_t aa; + I_ r; + FB_ + aa = (mp_limb_t)(R1.i); + r = RET_STGCALL3(StgInt, mpn_gcd_1, (mp_limb_t *)(&aa), 1, (mp_limb_t)(R2.i)); + RET_N(r); + FE_ +} + +FN_(gcdIntegerIntzh_fast) +{ + /* R1 = s1; R2 = d1; R3 = the int */ + I_ r; + FB_ + MAYBE_GC(R2_PTR, gcdIntegerIntzh_fast); + r = RET_STGCALL3(I_,mpn_gcd_1,(mp_limb_t *)(BYTE_ARR_CTS(R2.p)), R1.i, R3.i); + RET_N(r); + FE_ +} + +FN_(cmpIntegerIntzh_fast) +{ + /* R1 = s1; R2 = d1; R3 = the int */ + MP_INT arg; + I_ r; + FB_ + MAYBE_GC(R2_PTR, cmpIntegerIntzh_fast); + arg._mp_size = R1.i; + arg._mp_alloc = ((StgArrWords *)R2.p)->words; + arg._mp_d = (mp_limb_t *) (BYTE_ARR_CTS(R2.p)); + r = RET_STGCALL2(I_,mpz_cmp_si,&arg,R3.i); + RET_N(r); + FE_ +} + +FN_(cmpIntegerzh_fast) +{ + /* R1 = s1; R2 = d1; R3 = s2; R4 = d2 */ + MP_INT arg1, arg2; + I_ r; + FB_ + MAYBE_GC(R2_PTR | R4_PTR, cmpIntegerIntzh_fast); + arg1._mp_size = R1.i; + arg1._mp_alloc= ((StgArrWords *)R2.p)->words; + arg1._mp_d = (mp_limb_t *) (BYTE_ARR_CTS(R2.p)); + arg2._mp_size = R3.i; + arg2._mp_alloc= ((StgArrWords *)R4.p)->words; + arg2._mp_d = (mp_limb_t *) (BYTE_ARR_CTS(R4.p)); + r = RET_STGCALL2(I_,mpz_cmp,&arg1,&arg2); + RET_N(r); + FE_ +} + +FN_(integer2Intzh_fast) +{ + /* R1 = s; R2 = d */ + I_ r, s; + FB_ + s = R1.i; + if (s == 0) + r = 0; + else { + r = ((mp_limb_t *) (BYTE_ARR_CTS(R2.p)))[0]; + if (s < 0) r = -r; + } + RET_N(r); + FE_ +} + +FN_(integer2Wordzh_fast) +{ + /* R1 = s; R2 = d */ + I_ s; + W_ r; + FB_ + s = R1.i; + if (s == 0) + r = 0; + else { + r = ((mp_limb_t *) (BYTE_ARR_CTS(R2.p)))[0]; + if (s < 0) r = -r; + } + RET_N(r); + FE_ +} + + FN_(decodeFloatzh_fast) { MP_INT mantissa; @@ -875,6 +984,17 @@ FN_(yieldzh_fast) * * -------------------------------------------------------------------------- */ +FN_(isEmptyMVarzh_fast) +{ + /* args: R1 = MVar closure */ + I_ r; + FB_ + r = (I_)((GET_INFO((StgMVar*)(R1.p))) == &stg_EMPTY_MVAR_info); + RET_N(r); + FE_ +} + + FN_(newMVarzh_fast) { StgMVar *mvar; @@ -1218,6 +1338,31 @@ FN_(makeStableNamezh_fast) RET_P(sn_obj); } + +FN_(makeStablePtrzh_fast) +{ + /* Args: R1 = a */ + StgStablePtr sp; + FB_ + MAYBE_GC(R1_PTR, makeStablePtrzh_fast); + sp = RET_STGCALL1(StgStablePtr,getStablePtr,R1.p); + RET_N(sp); + FE_ +} + +FN_(deRefStablePtrzh_fast) +{ + /* Args: R1 = the stable ptr */ + P_ r; + StgStablePtr sp; + FB_ + sp = (StgStablePtr)R1.w; + ASSERT(stable_ptr_table[(StgWord)sp].weight > 0); + r = stable_ptr_table[(StgWord)sp].addr; + RET_P(r); + FE_ +} + /* ----------------------------------------------------------------------------- Bytecode object primitives ------------------------------------------------------------------------- */ |