X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FCgExpr.lhs;h=3b752673858098cbf1ec4f3e5ae1f394c3dc07ee;hp=a71493a28b52d4815cd1d23c8deb0d081b3b037b;hb=176fa33f17dd78355cc572e006d2ab26898e2c69;hpb=affbe8dae5d7eb350686b42ddbd4f3561b7bd0ec diff --git a/compiler/codeGen/CgExpr.lhs b/compiler/codeGen/CgExpr.lhs index a71493a..3b75267 100644 --- a/compiler/codeGen/CgExpr.lhs +++ b/compiler/codeGen/CgExpr.lhs @@ -4,6 +4,13 @@ % \begin{code} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module CgExpr ( cgExpr ) where #include "HsVersions.h" @@ -30,7 +37,7 @@ import CgHpc import CgUtils import ClosureInfo import Cmm -import MachOp +import CmmUtils import VarSet import Literal import PrimOp @@ -41,6 +48,7 @@ import Maybes import ListSetOps import BasicTypes import Util +import FastString import Outputable \end{code} @@ -121,18 +129,15 @@ cgExpr (StgOpApp (StgFCallOp fcall _) stg_args res_ty) = do | (stg_arg, (rep,expr)) <- stg_args `zip` reps_n_amodes, nonVoidArg rep] - arg_tmps <- sequence [ - if isFollowableArg (typeCgRep (stgArgType stg_arg)) - then assignPtrTemp arg - else assignNonPtrTemp arg - | (arg, stg_arg) <- arg_exprs] - let arg_hints = zip arg_tmps (map (typeHint.stgArgType) stg_args) + arg_tmps <- sequence [ assignTemp arg + | (arg, stg_arg) <- arg_exprs] + let arg_hints = zipWith CmmHinted arg_tmps (map (typeForeignHint.stgArgType) stg_args) {- Now, allocate some result regs. -} (res_reps,res_regs,res_hints) <- newUnboxedTupleRegs res_ty ccallReturnUnboxedTuple (zip res_reps (map (CmmReg . CmmLocal) res_regs)) $ - emitForeignCall (zip res_regs res_hints) fcall + emitForeignCall (zipWith CmmHinted res_regs res_hints) fcall arg_hints emptyVarSet{-no live vars-} -- tagToEnum# is special: we need to pull the constructor out of the table, @@ -141,13 +146,9 @@ cgExpr (StgOpApp (StgFCallOp fcall _) stg_args res_ty) = do cgExpr (StgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty) = ASSERT(isEnumerationTyCon tycon) do { (rep,amode) <- getArgAmode arg - ; amode' <- if isFollowableArg rep - then assignPtrTemp amode - else assignNonPtrTemp amode - -- We're going to use it twice, + ; amode' <- assignTemp amode -- We're going to use it twice, -- so save in a temp if non-trivial - ; this_pkg <- getThisPackage - ; stmtC (CmmAssign nodeReg (tagToClosure this_pkg tycon amode')) + ; stmtC (CmmAssign nodeReg (tagToClosure tycon amode')) ; performReturn emitReturnInstr } where -- If you're reading this code in the attempt to figure @@ -167,9 +168,7 @@ cgExpr x@(StgOpApp op@(StgPrimOp primop) args res_ty) performReturn emitReturnInstr | ReturnsPrim rep <- result_info - = do res <- if isFollowableArg (typeCgRep res_ty) - then newPtrTemp (argMachRep (typeCgRep res_ty)) - else newNonPtrTemp (argMachRep (typeCgRep res_ty)) + = do res <- newTemp (typeCmmType res_ty) cgPrimOp [res] primop args emptyVarSet performPrimReturn (primRepToCgRep rep) (CmmReg (CmmLocal res)) @@ -180,13 +179,10 @@ cgExpr x@(StgOpApp op@(StgPrimOp primop) args res_ty) | ReturnsAlg tycon <- result_info, isEnumerationTyCon tycon -- c.f. cgExpr (...TagToEnumOp...) - = do tag_reg <- if isFollowableArg (typeCgRep res_ty) - then newPtrTemp wordRep - else newNonPtrTemp wordRep - this_pkg <- getThisPackage + = do tag_reg <- newTemp bWord -- The tag is a word cgPrimOp [tag_reg] primop args emptyVarSet stmtC (CmmAssign nodeReg - (tagToClosure this_pkg tycon + (tagToClosure tycon (CmmReg (CmmLocal tag_reg)))) performReturn emitReturnInstr where @@ -292,8 +288,7 @@ cgRhs name (StgRhsCon maybe_cc con args) ; returnFC (name, idinfo) } cgRhs name (StgRhsClosure cc bi fvs upd_flag srt args body) - = do this_pkg <- getThisPackage - setSRT srt $ mkRhsClosure this_pkg name cc bi fvs upd_flag args body + = setSRT srt $ mkRhsClosure name cc bi fvs upd_flag args body \end{code} mkRhsClosure looks for two special forms of the right-hand side: @@ -316,7 +311,7 @@ form: \begin{code} -mkRhsClosure this_pkg bndr cc bi +mkRhsClosure bndr cc bi [the_fv] -- Just one free var upd_flag -- Updatable thunk [] -- A thunk @@ -338,7 +333,7 @@ mkRhsClosure this_pkg bndr cc bi where lf_info = mkSelectorLFInfo bndr offset_into_int (isUpdatable upd_flag) - (_, params_w_offsets) = layOutDynConstr this_pkg con (addIdReps params) + (_, params_w_offsets) = layOutDynConstr con (addIdReps params) -- Just want the layout maybe_offset = assocMaybe params_w_offsets selectee Just the_offset = maybe_offset @@ -362,7 +357,7 @@ We only generate an Ap thunk if all the free variables are pointers, for semi-obvious reasons. \begin{code} -mkRhsClosure this_pkg bndr cc bi +mkRhsClosure bndr cc bi fvs upd_flag [] -- No args; a thunk @@ -387,7 +382,7 @@ mkRhsClosure this_pkg bndr cc bi The default case ~~~~~~~~~~~~~~~~ \begin{code} -mkRhsClosure this_pkg bndr cc bi fvs upd_flag args body +mkRhsClosure bndr cc bi fvs upd_flag args body = cgRhsClosure bndr cc bi fvs upd_flag args body \end{code} @@ -451,16 +446,14 @@ cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder Little helper for primitives that return unboxed tuples. \begin{code} -newUnboxedTupleRegs :: Type -> FCode ([CgRep], [LocalReg], [MachHint]) +newUnboxedTupleRegs :: Type -> FCode ([CgRep], [LocalReg], [ForeignHint]) newUnboxedTupleRegs res_ty = let ty_args = tyConAppArgs (repType res_ty) - (reps,hints) = unzip [ (rep, typeHint ty) | ty <- ty_args, + (reps,hints) = unzip [ (rep, typeForeignHint ty) | ty <- ty_args, let rep = typeCgRep ty, nonVoidArg rep ] - make_new_temp rep = if isFollowableArg rep - then newPtrTemp (argMachRep rep) - else newNonPtrTemp (argMachRep rep) + make_new_temp rep = newTemp (argMachRep rep) in do regs <- mapM make_new_temp reps return (reps,regs,hints)