{-# LANGUAGE GADTs #-}moduleCmmImplementSwitchPlans(cmmImplementSwitchPlans )whereimportGhcPrelude importHoopl.Block importBlockId importCmm importCmmUtils importCmmSwitch importUniqSupply importDynFlags ---- This module replaces Switch statements as generated by the Stg -> Cmm-- transformation, which might be huge and sparse and hence unsuitable for-- assembly code, by proper constructs (if-then-else trees, dense jump tables).---- The actual, abstract strategy is determined by createSwitchPlan in-- CmmSwitch and returned as a SwitchPlan; here is just the implementation in-- terms of Cmm code. See Note [Cmm Switches, the general plan] in CmmSwitch.---- This division into different modules is both to clearly separate concerns,-- but also because createSwitchPlan needs access to the constructors of-- SwitchTargets, a data type exported abstractly by CmmSwitch.---- | Traverses the 'CmmGraph', making sure that 'CmmSwitch' are suitable for-- code generation.cmmImplementSwitchPlans::DynFlags ->CmmGraph ->UniqSM CmmGraph cmmImplementSwitchPlans dflags g |targetSupportsSwitch (hscTargetdflags )=returng |otherwise=doblocks' <-concat`fmap`mapM(visitSwitches dflags )(toBlockList g )return$ofBlockList (g_entryg )blocks' visitSwitches::DynFlags ->CmmBlock ->UniqSM [CmmBlock ]visitSwitches dflags block |(entry @(CmmEntry _scope ),middle ,CmmSwitch expr ids )<-blockSplit block =doletplan =createSwitchPlan ids (newTail ,newBlocks )<-implementSwitchPlan dflags scope expr plan letblock' =entry `blockJoinHead `middle `blockAppend `newTail return$block' :newBlocks |otherwise=return[block ]-- Implementing a switch plan (returning a tail block)implementSwitchPlan::DynFlags ->CmmTickScope ->CmmExpr ->SwitchPlan ->UniqSM (Block CmmNode O C ,[CmmBlock ])implementSwitchPlan dflags scope expr =go wherego (Unconditionally l )=return(emptyBlock `blockJoinTail `CmmBranch l ,[])go(JumpTable ids )=return(emptyBlock `blockJoinTail `CmmSwitch expr ids ,[])go(IfLT signed i ids1 ids2 )=do(bid1 ,newBlocks1 )<-go' ids1 (bid2 ,newBlocks2 )<-go' ids2 letlt |signed =cmmSLtWord |otherwise=cmmULtWord scrut =lt dflags expr $CmmLit $mkWordCLit dflags i lastNode =CmmCondBranch scrut bid1 bid2 NothinglastBlock =emptyBlock `blockJoinTail `lastNode return(lastBlock ,newBlocks1 ++newBlocks2 )go(IfEqual i l ids2 )=do(bid2 ,newBlocks2 )<-go' ids2 letscrut =cmmNeWord dflags expr $CmmLit $mkWordCLit dflags i lastNode =CmmCondBranch scrut bid2 l NothinglastBlock =emptyBlock `blockJoinTail `lastNode return(lastBlock ,newBlocks2 )-- Same but returning a label to branch togo' (Unconditionally l )=return(l ,[])go'p =dobid <-mkBlockId `fmap`getUniqueM (last ,newBlocks )<-go p letblock =CmmEntry bid scope `blockJoinHead `last return(bid ,block :newBlocks )