{-# LANGUAGE PatternGuards #-}moduleCmmCvt(cmmToZgraph,cmmOfZgraph)whereimportBlockIdimportCmmimportMkZipCfgCmmhiding(CmmGraph)importZipCfgCmmRep-- imported for reverse conversionimportCmmZipUtilimportPprCmm()importqualifiedZipCfgasGimportFastStringimportControl.MonadimportOutputableimportUniqSupplycmmToZgraph::GenCmmdh(ListGraphCmmStmt)->UniqSM(GenCmmdh(CmmStackInfo,CmmGraph))cmmOfZgraph::GenCmmdh(CmmStackInfo,CmmGraph)->GenCmmdh(ListGraphCmmStmt)cmmToZgraph(Cmmtops)=liftMCmm$mapMmapToptopswheremapTop(CmmProchlargsg)=toZgraph(showSDoc$pprl)argsg>>=return.CmmProchlargsmapTop(CmmDatasds)=return$CmmDatasdscmmOfZgraph=cmmMapGraph(ofZgraph.snd)toZgraph::String->CmmFormals->ListGraphCmmStmt->UniqSM(CmmStackInfo,CmmGraph)toZgraph__(ListGraph[])=dog<-lgraphOfAGraphemptyAGraphreturn((0,Nothing),g)toZgraphfun_nameargsg@(ListGraph(BasicBlockidss:other_blocks))=let(offset,entry)=mkEntryidNativeNodeCallargsindog<-labelAGraphid$entry<*>mkStmtsss<*>foldraddBlockemptyAGraphother_blocksreturn((offset,Nothing),g)whereaddBlock(BasicBlockidss)g=mkLabelid<*>mkStmtsss<*>gupdfr_sz=0-- panic "upd frame size lost in cmm conversion"mkStmts(CmmNop:ss)=mkNop<*>mkStmtsssmkStmts(CmmComments:ss)=mkComments<*>mkStmtsssmkStmts(CmmAssignlr:ss)=mkAssignlr<*>mkStmtsssmkStmts(CmmStorelr:ss)=mkStorelr<*>mkStmtsssmkStmts(CmmCall(CmmCalleefconv)resargs(CmmSafe_)CmmMayReturn:ss)=mkCallf(conv',conv')(maphintlessCmmres)(maphintlessCmmargs)updfr_sz<*>mkStmtssswhereconv'=Foreign(ForeignConventionconv[][])-- JD: DUBIOUSmkStmts(CmmCall(CmmPrim{})__(CmmSafe_)_:_)=panic"safe call to a primitive CmmPrim CallishMachOp"mkStmts(CmmCallfresargsCmmUnsafeCmmMayReturn:ss)=mkUnsafeCall(convert_targetfresargs)(strip_hintsres)(strip_hintsargs)<*>mkStmtsssmkStmts(CmmCondBranchel:fbranch)=mkCmmIfThenElsee(mkBranchl)(mkStmtsfbranch)mkStmts(last:[])=mkLastlastmkStmts[]=bad"fell off end"mkStmts(_:_:_)=bad"last node not at end"badmsg=pprPanic(msg++" in function "++fun_name)(pprg)mkLast(CmmCall(CmmCalleefconv)[]args_CmmNeverReturns)=mkFinalCallfconv(maphintlessCmmargs)updfr_szmkLast(CmmCall(CmmPrim{})___CmmNeverReturns)=panic"Call to CmmPrim never returns?!"mkLast(CmmSwitchscrutineetable)=mkSwitchscrutineetable-- SURELY, THESE HINTLESS ARGS ARE WRONG AND WILL BE FIXED WHEN CALLING-- CONVENTIONS ARE HONORED?mkLast(CmmJumptgtargs)=mkJumptgt(maphintlessCmmargs)updfr_szmkLast(CmmReturnress)=mkReturnSimple(maphintlessCmmress)updfr_szmkLast(CmmBranchtgt)=mkBranchtgtmkLast(CmmCall_f(_:_)_args_CmmNeverReturns)=panic"Call never returns but has results?!"mkLast_=panic"fell off end of block"strip_hints::[CmmHinteda]->[a]strip_hints=maphintlessCmmconvert_target::CmmCallTarget->HintedCmmFormals->HintedCmmActuals->MidCallTargetconvert_target(CmmCalleeecc)ressargs=ForeignTargete(ForeignConventioncc(mapcmmHintargs)(mapcmmHintress))convert_target(CmmPrimop)_ress_args=PrimTargetopadd_hints::Convention->ValueDirection->[a]->[CmmHinteda]add_hintsconvvdargs=zipWithCmmHintedargs(get_hintsconvvd)get_hints::Convention->ValueDirection->[ForeignHint]get_hints(Foreign(ForeignConvention_hints_))Arguments=hintsget_hints(Foreign(ForeignConvention__hints))Results=hintsget_hints_other_conv_vd=repeatNoHintget_conv::MidCallTarget->Conventionget_conv(PrimTarget_)=NativeNodeCall-- JD: SUSPICIOUSget_conv(ForeignTarget_fc)=Foreignfccmm_target::MidCallTarget->CmmCallTargetcmm_target(PrimTargetop)=CmmPrimopcmm_target(ForeignTargete(ForeignConventioncc__))=CmmCalleeeccofZgraph::CmmGraph->ListGraphCmmStmtofZgraphg=ListGraph$swallowblockswhereblocks=G.postorder_dfsg-- | the next two functions are hooks on which to hang debugging infoextend_entrystmts=stmtsextend_block_idstmts=stmts_extend_entrystmts=scommentshowblocks:scommentcscomm:stmtsshowblocks="LGraph has "++show(lengthblocks)++" blocks:"++concat(map(\(G.Blockid_)->" "++showid)blocks)cscomm="Call successors are"++(concat$map(\id->" "++showid)$blockSetToListcall_succs)swallow[]=[]swallow(G.Blockidt:rest)=tailid[]tresttailidprev'(G.ZTailmt)rest=tailid(midm:prev')tresttailidprev'(G.ZLastG.LastExit)rest=exitidprev'resttailidprev'(G.ZLast(G.LastOtherl))rest=lastidprev'lrestmid(MidComments)=CmmCommentsmid(MidAssignlr)=CmmAssignlrmid(MidStorelr)=CmmStorelrmid(MidForeignCall_targetressargs)=CmmCall(cmm_targettarget)(add_hintsconvResultsress)(add_hintsconvArgumentsargs)CmmUnsafeCmmMayReturnwhereconv=get_convtargetblock'idprev'|id==G.lg_entryg=BasicBlockid$extend_entry(reverseprev')|otherwise=BasicBlockid$extend_blockid(reverseprev')lastidprev'ln=letendblockstmt=block'id(stmt:prev'):swallownincaselofLastBranchtgt->casenof-- THIS OPT IS WRONG -- LABELS CAN SHOW UP ELSEWHERE IN THE GRAPH--G.Block id' _ t : bs-- | tgt == id', unique_pred id' -- -> tail id prev' t bs -- optimize out redundant labels_->endblock(CmmBranchtgt)LastCondBranchexprtidfid->casenofG.Blockid't:bs-- It would be better to handle earlier, but we still must-- generate correct code here.|id'==fid,tid==fid,unique_predid'->tailidprev'tbs|id'==fid,unique_predid'->tailid(CmmCondBranchexprtid:prev')tbs|id'==tid,unique_predid',Juste'<-maybeInvertCmmExprexpr->tailid(CmmCondBranche'fid:prev')tbs_->letinstrs'=CmmBranchfid:CmmCondBranchexprtid:prev'inblock'idinstrs':swallownLastSwitchargids->endblock$CmmSwitcharg$idsLastCalle____->endblock$CmmJumpe[]exitidprev'n=-- highly irregular (assertion violation?)letendblockstmt=block'id(stmt:prev'):swallownincasenof[]->endblock(scomment"procedure falls off end")G.Blockid't:bs->ifunique_predid'thentailid(scomment"went thru exit":prev')tbselseendblock(CmmBranchid')preds=zipPredsgsingle_preds=letaddbsingle=letid=G.blockIdbincaselookupBlockEnvpredsidofNothing->singleJusts->ifsizeBlockSets==1thenextendBlockSetsingleidelsesingleinG.fold_blocksaddemptyBlockSetgunique_predid=elemBlockSetidsingle_predscall_succs=letaddbsuccs=caseG.last(G.unzipb)ofG.LastOther(LastCall_(Justid)___)->extendBlockSetsuccsid_->succsinG.fold_blocksaddemptyBlockSetg_is_call_succid=elemBlockSetidcall_succsscomment::String->CmmStmtscomments=CmmComment$mkFastStrings