X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FCgClosure.lhs;h=499442fdaaf057f6114e07afc40a9294dc0f72bc;hp=1a2cbc5202e0e60333ab78d0dc8b8d0e9140675a;hb=7fc749a43b4b6b85d234fa95d4928648259584f4;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1 diff --git a/compiler/codeGen/CgClosure.lhs b/compiler/codeGen/CgClosure.lhs index 1a2cbc5..499442f 100644 --- a/compiler/codeGen/CgClosure.lhs +++ b/compiler/codeGen/CgClosure.lhs @@ -1,8 +1,7 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgClosure.lhs,v 1.72 2005/05/18 12:06:51 simonmar Exp $ -% \section[CgClosure]{Code generation for closures} This module provides the support code for @StgToAbstractC@ to deal @@ -10,6 +9,13 @@ with {\em closures} on the RHSs of let(rec)s. See also @CgCon@, which deals with constructors. \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 CgClosure ( cgTopRhsClosure, cgStdRhsClosure, cgRhsClosure, @@ -23,36 +29,32 @@ import {-# SOURCE #-} CgExpr ( cgExpr ) import CgMonad import CgBindery import CgHeapery -import CgStackery ( mkVirtStkOffsets, pushUpdateFrame, getVirtSp, - setRealAndVirtualSp ) -import CgProf ( chooseDynCostCentres, ldvEnter, enterCostCentre, - costCentreFrom ) +import CgStackery +import CgProf import CgTicky -import CgParallel ( granYield, granFetchAndReschedule ) -import CgInfoTbls ( emitClosureCodeAndInfoTable, getSRTInfo ) -import CgCallConv ( assignCallRegs, mkArgDescr ) -import CgUtils ( emitDataLits, addIdReps, cmmRegOffW, - emitRtsCallWithVols ) -import ClosureInfo -- lots and lots of stuff -import SMRep ( CgRep, cgRepSizeW, argMachRep, fixedHdrSize, WordOff, - idCgRep ) -import MachOp ( MachHint(..) ) +import CgParallel +import CgInfoTbls +import CgCallConv +import CgUtils +import ClosureInfo +import SMRep +import MachOp import Cmm -import CmmUtils ( CmmStmts, mkStmts, oneStmt, plusStmts, noStmts, - mkLblExpr ) +import CmmUtils import CLabel import StgSyn -import StaticFlags ( opt_DoTickyProfiling ) import CostCentre -import Id ( Id, idName, idType ) -import Name ( Name, isExternalName ) -import Module ( Module, pprModule ) -import ListSetOps ( minusList ) -import Util ( isIn, mapAccumL, zipWithEqual ) -import BasicTypes ( TopLevelFlag(..) ) -import Constants ( oFFSET_StgInd_indirectee, wORD_SIZE ) +import Id +import Name +import Module +import ListSetOps +import Util +import BasicTypes +import Constants import Outputable import FastString + +import Data.List \end{code} %******************************************************** @@ -68,18 +70,17 @@ They should have no free variables. cgTopRhsClosure :: Id -> CostCentreStack -- Optional cost centre annotation -> StgBinderInfo - -> SRT -> UpdateFlag -> [Id] -- Args -> StgExpr -> FCode (Id, CgIdInfo) -cgTopRhsClosure id ccs binder_info srt upd_flag args body = do +cgTopRhsClosure id ccs binder_info upd_flag args body = do { -- LAY OUT THE OBJECT let name = idName id ; lf_info <- mkClosureLFInfo id TopLevel [] upd_flag args - ; srt_info <- getSRTInfo name srt - ; mod_name <- moduleName + ; srt_info <- getSRTInfo + ; mod_name <- getModuleName ; let descr = closureDescription mod_name name closure_info = mkClosureInfo True id lf_info 0 0 srt_info descr closure_label = mkLocalClosureLabel name @@ -118,7 +119,7 @@ cgStdRhsClosure bndr cc bndr_info fvs args body lf_info payload = do -- AHA! A STANDARD-FORM THUNK { -- LAY OUT THE OBJECT amodes <- getArgAmodes payload - ; mod_name <- moduleName + ; mod_name <- getModuleName ; let (tot_wds, ptr_wds, amodes_w_offsets) = mkVirtHeapOffsets (isLFThunk lf_info) amodes @@ -143,14 +144,13 @@ Here's the general case. cgRhsClosure :: Id -> CostCentreStack -- Optional cost centre annotation -> StgBinderInfo - -> SRT -> [Id] -- Free vars -> UpdateFlag -> [Id] -- Args -> StgExpr -> FCode (Id, CgIdInfo) -cgRhsClosure bndr cc bndr_info srt fvs upd_flag args body = do +cgRhsClosure bndr cc bndr_info fvs upd_flag args body = do { -- LAY OUT THE OBJECT -- If the binder is itself a free variable, then don't store -- it in the closure. Instead, just bind it to Node on entry. @@ -168,8 +168,8 @@ cgRhsClosure bndr cc bndr_info srt fvs upd_flag args body = do ; lf_info <- mkClosureLFInfo bndr NotTopLevel fvs upd_flag args ; fv_infos <- mapFCs getCgIdInfo reduced_fvs - ; srt_info <- getSRTInfo name srt - ; mod_name <- moduleName + ; srt_info <- getSRTInfo + ; mod_name <- getModuleName ; let bind_details :: [(CgIdInfo, VirtualHpOffset)] (tot_wds, ptr_wds, bind_details) = mkVirtHeapOffsets (isLFThunk lf_info) (map add_rep fv_infos) @@ -184,7 +184,14 @@ cgRhsClosure bndr cc bndr_info srt fvs upd_flag args body = do -- BUILD ITS INFO TABLE AND CODE ; forkClosureBody (do { -- Bind the fvs - let bind_fv (info, offset) + let + -- A function closure pointer may be tagged, so we + -- must take it into account when accessing the free variables. + mbtag = tagForArity (length args) + bind_fv (info, offset) + | Just tag <- mbtag + = bindNewToUntagNode (cgIdInfoId info) offset (cgIdInfoLF info) tag + | otherwise = bindNewToNode (cgIdInfoId info) offset (cgIdInfoLF info) ; mapCs bind_fv bind_details @@ -243,7 +250,7 @@ NB: Thunks cannot have a primitive type! closureCodeBody binder_info cl_info cc [{- No args i.e. thunk -}] body = do { body_absC <- getCgStmts $ do { tickyEnterThunk cl_info - ; ldvEnter (CmmReg nodeReg) -- NB: Node always points when profiling + ; ldvEnterClosure cl_info -- NB: Node always points when profiling ; thunkWrapper cl_info $ do -- We only enter cc after setting up update so -- that cc of enclosing scope will be recorded @@ -407,8 +414,19 @@ funWrapper :: ClosureInfo -- Closure whose code body this is funWrapper closure_info arg_regs reg_save_code fun_body = do { let node_points = nodeMustPointToIt (closureLFInfo closure_info) + {- + -- Debugging: check that R1 has the correct tag + ; let tag = funTag closure_info + ; whenC (tag /= 0 && node_points) $ do + l <- newLabelC + stmtC (CmmCondBranch (CmmMachOp mo_wordEq [cmmGetTag (CmmReg nodeReg), + CmmLit (mkIntCLit tag)]) l) + stmtC (CmmStore (CmmLit (mkWordCLit 0)) (CmmLit (mkWordCLit 0))) + labelC l + -} + -- Enter for Ldv profiling - ; whenC node_points (ldvEnter (CmmReg nodeReg)) + ; whenC node_points (ldvEnterClosure closure_info) -- GranSim yeild poin ; granYield arg_regs node_points @@ -453,12 +471,12 @@ emitBlackHoleCode is_single_entry -- Profiling needs slop filling (to support LDV profiling), so -- currently eager blackholing doesn't work with profiling. -- - -- TICKY_TICKY needs EAGER_BLACKHOLING to verify no double-entries of - -- single-entry thunks. - eager_blackholing - | opt_DoTickyProfiling = True - | otherwise = False + -- Previously, eager blackholing was enabled when ticky-ticky + -- was on. But it didn't work, and it wasn't strictly necessary + -- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING + -- is unconditionally disabled. -- krc 1/2007 + eager_blackholing = False \end{code} \begin{code} @@ -481,17 +499,9 @@ setupUpdate closure_info code ; if closureUpdReqd closure_info then do -- Blackhole the (updatable) CAF: { upd_closure <- link_caf closure_info True - ; pushUpdateFrame upd_closure code } + ; pushUpdateFrame upd_closure code } else do - { -- No update reqd, you'd think we don't need to - -- black-hole it. But when ticky-ticky is on, we - -- black-hole it regardless, to catch errors in which - -- an allegedly single-entry closure is entered twice - -- - -- We discard the pointer returned by link_caf, because - -- we don't push an update frame - whenC opt_DoTickyProfiling -- Blackhole even a SE CAF - (link_caf closure_info False >> nopC) + { -- krc: removed some ticky-related code here. ; tickyUpdateFrameOmitted ; code } } @@ -550,7 +560,7 @@ link_caf cl_info is_upd = do -- so that the garbage collector can find them -- This must be done *before* the info table pointer is overwritten, -- because the old info table ptr is needed for reversion - ; emitRtsCallWithVols SLIT("newCAF") [(CmmReg nodeReg,PtrHint)] [node] + ; emitRtsCallWithVols SLIT("newCAF") [(CmmReg nodeReg,PtrHint)] [node] False -- node is live, so save it. -- Overwrite the closure with a (static) indirection