X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FnativeGen%2FStixPrim.lhs;h=034e6410259cfa6169a3086b1b73159420bcc586;hb=0b3dcf9dd504c2db156d08f1908e906e00e66c7a;hp=9d694b915cfa4210716beb7e183109e14c0766ea;hpb=37ff4336c8ef3833a3f7f2a9b5f5bf0b06c363f7;p=ghc-hetmet.git diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs index 9d694b9..034e641 100644 --- a/ghc/compiler/nativeGen/StixPrim.lhs +++ b/ghc/compiler/nativeGen/StixPrim.lhs @@ -14,17 +14,18 @@ import StixInteger import AbsCSyn hiding ( spRel ) import AbsCUtils ( getAmodeRep, mixedTypeLocn ) -import Constants ( uF_UPDATEE ) import SMRep ( fixedHdrSize ) import Literal ( Literal(..), word2IntLit ) import CallConv ( cCallConv ) import PrimOp ( PrimOp(..), CCall(..), CCallTarget(..) ) import PrimRep ( PrimRep(..), isFloatingRep ) -import UniqSupply ( returnUs, thenUs, UniqSM ) -import Constants ( mIN_INTLIKE ) +import UniqSupply ( returnUs, thenUs, getUniqueUs, UniqSM ) +import Constants ( mIN_INTLIKE, uF_UPDATEE, bLOCK_SIZE ) import Outputable -import Char ( ord ) +import Char ( ord, isAlphaNum ) + +#include "NCG.h" \end{code} The main honcho here is primCode, which handles the guts of COpStmts. @@ -91,6 +92,12 @@ primCode [res] SameMutableArrayOp args primCode res@[_] SameMutableByteArrayOp args = primCode res SameMutableArrayOp args + +primCode res@[_] SameMutVarOp args + = primCode res SameMutableArrayOp args + +primCode res@[_] SameMVarOp args + = primCode res SameMutableArrayOp args \end{code} Freezing an array of pointers is a double assignment. We fix the @@ -195,7 +202,7 @@ primCode [lhs] (IndexOffForeignObjOp pk) [obj, ix] lhs' = amodeToStix lhs obj' = amodeToStix obj ix' = amodeToStix ix - obj'' = StIndex PtrRep obj' fixedHS + obj'' = StIndex AddrRep obj' fixedHS assign = StAssign pk lhs' (StInd pk (StIndex pk obj'' ix')) in returnUs (\xs -> assign : xs) @@ -218,22 +225,36 @@ primCode [] (WriteByteArrayOp pk) [obj, ix, v] assign = StAssign pk (StInd pk (StIndex pk 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) \end{code} +ToDo: saving/restoring of volatile regs around ccalls. + \begin{code} ---primCode lhs (CCallOp fn is_asm may_gc) rhs primCode lhs (CCallOp (CCall (StaticTarget fn) is_asm may_gc cconv)) rhs | is_asm = error "ERROR: Native code generator can't handle casm" - | may_gc = error "ERROR: Native code generator can't handle _ccall_GC_\n" - | otherwise - = case lhs of - [] -> returnUs (\xs -> (StCall fn cconv VoidRep args) : xs) - [lhs] -> - let lhs' = amodeToStix lhs - pk = if isFloatingRep (getAmodeRep lhs) then DoubleRep else IntRep - call = StAssign pk lhs' (StCall fn cconv pk args) - in - returnUs (\xs -> call : xs) + | not may_gc = returnUs (\xs -> ccall : xs) + | otherwise = + save_thread_state `thenUs` \ save -> + load_thread_state `thenUs` \ load -> + getUniqueUs `thenUs` \ uniq -> + let + id = StReg (StixTemp uniq IntRep) + + suspend = StAssign IntRep id + (StCall SLIT("suspendThread") cconv IntRep [stgBaseReg]) + resume = StCall SLIT("resumeThread") cconv VoidRep [id] + in + returnUs (\xs -> save (suspend : ccall : resume : load xs)) + where args = map amodeCodeForCCall rhs amodeCodeForCCall x = @@ -244,6 +265,14 @@ primCode lhs (CCallOp (CCall (StaticTarget fn) is_asm may_gc cconv)) rhs ByteArrayRep -> StIndex IntRep base arrWordsHS ForeignObjRep -> StIndex PtrRep base fixedHS _ -> base + + ccall = case lhs of + [] -> StCall fn cconv VoidRep args + [lhs] -> + let lhs' = amodeToStix lhs + pk = if isFloatingRep (getAmodeRep lhs) then DoubleRep else IntRep + in + StAssign pk lhs' (StCall fn cconv pk args) \end{code} DataToTagOp won't work for 64-bit archs, as it is. @@ -434,12 +463,11 @@ amodeToStix (CMacroExpr _ macro [arg]) litLitToStix :: String -> StixTree litLitToStix nm - = case nm of - "stdout" -> stixFor_stdout - "stderr" -> stixFor_stderr - "stdin" -> stixFor_stdin - other -> error ("\nlitLitToStix: can't handle `" ++ nm ++ "'\n" + | all is_id nm = StLitLbl (text nm) + | otherwise = error ("\nlitLitToStix: can't handle `" ++ nm ++ "'\n" ++ "suggested workaround: use flag -fvia-C\n") + + where is_id c = isAlphaNum c || c == '_' \end{code} Sizes of the CharLike and IntLike closures that are arranged as arrays @@ -470,3 +498,62 @@ mutArrPtrsFrozen_info = sStLitLbl SLIT("MUT_ARR_PTRS_FROZEN_info") charLikeSize = (fixedHdrSize + 1) * (fromInteger (sizeOf PtrRep)) intLikeSize = (fixedHdrSize + 1) * (fromInteger (sizeOf PtrRep)) \end{code} + + +\begin{code} +save_thread_state + = getUniqueUs `thenUs` \tso_uq -> + let tso = StReg (StixTemp 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 + [tso, StInt (toInteger (TSO_SPLIM*BYTES_PER_WORD))])) + stgSpLim : + StAssign PtrRep + (StInd PtrRep (StPrim IntAddOp + [stgCurrentNursery, + StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))])) + (StPrim IntAddOp [stgHp, StInt (toInteger (1 * BYTES_PER_WORD))]) : + xs + ) + +load_thread_state + = getUniqueUs `thenUs` \tso_uq -> + let tso = StReg (StixTemp 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 + (StInd PtrRep (StPrim IntAddOp + [tso, StInt (toInteger (TSO_SPLIM*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 + ) +\end{code}