X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FnativeGen%2FAsmRegAlloc.lhs;h=90b379a8b88877b6f3e1bc0f5d64d3acebee5a2e;hb=553e90d9a32ee1b1809430f260c401cc4169c6c7;hp=29061de5bfd2d39920f4ecdc64d8166ff9ca0089;hpb=6c381e873e222417d9a67aeec77b9555eca7b7a8;p=ghc-hetmet.git diff --git a/ghc/compiler/nativeGen/AsmRegAlloc.lhs b/ghc/compiler/nativeGen/AsmRegAlloc.lhs index 29061de..90b379a 100644 --- a/ghc/compiler/nativeGen/AsmRegAlloc.lhs +++ b/ghc/compiler/nativeGen/AsmRegAlloc.lhs @@ -1,507 +1,941 @@ % -% (c) The AQUA Project, Glasgow University, 1993-1995 +% (c) The AQUA Project, Glasgow University, 1993-2000 % +\section[AsmRegAlloc]{Register allocator} \begin{code} -#include "HsVersions.h" -#include "../../includes/platform.h" -#include "../../includes/GhcConstants.h" - -module AsmRegAlloc ( - FutureLive(..), RegLiveness(..), RegUsage(..), Reg(..), - MachineRegisters(..), MachineCode(..), +module AsmRegAlloc ( runRegAllocate ) where - mkReg, runRegAllocate, runHairyRegAllocate, - extractMappedRegNos +#include "HsVersions.h" - -- And, for self-sufficiency - ) where +import MachCode ( InstrBlock ) +import MachMisc ( Instr(..) ) +import PprMach ( pprInstr ) -- Just for debugging +import MachRegs +import RegAllocInfo -import CLabel ( CLabel ) -import FiniteMap -import MachDesc -import Maybes ( maybeToBool, Maybe(..) ) -import OrdList -- ( mkUnitList, mkSeqList, mkParList, OrdList ) +import FiniteMap ( FiniteMap, emptyFM, + lookupFM, eltsFM, addToFM_C, addToFM, + listToFM, fmToList ) +import OrdList ( fromOL ) import Outputable -import Pretty -import UniqSet -import Unique ( Unique ) -import Util - -#if ! OMIT_NATIVE_CODEGEN - -# if alpha_TARGET_ARCH -import AlphaCode -- ( AlphaInstr, AlphaRegs ) -- for specializing - -{-# SPECIALIZE - runRegAllocate :: AlphaRegs -> [Int] -> (OrdList AlphaInstr) -> [AlphaInstr] - #-} -# endif - -# if i386_TARGET_ARCH -import I386Code -- ( I386Instr, I386Regs ) -- for specializing - -{-# SPECIALIZE - runRegAllocate :: I386Regs -> [Int] -> (OrdList I386Instr) -> [I386Instr] - #-} -# endif - -# if sparc_TARGET_ARCH -import SparcCode -- ( SparcInstr, SparcRegs ) -- for specializing - -{-# SPECIALIZE - runRegAllocate :: SparcRegs -> [Int] -> (OrdList SparcInstr) -> [SparcInstr] - #-} -# endif - -#endif +import Unique ( mkPseudoUnique3 ) +import CLabel ( CLabel, pprCLabel ) +import FastTypes +import List ( mapAccumL, nub, sort ) +import Array ( Array, array, (!), bounds ) \end{code} -%************************************************************************ -%* * -\subsection[Reg]{Real registers} -%* * -%************************************************************************ - -Static Registers correspond to actual machine registers. These should -be avoided until the last possible moment. - -Dynamic registers are allocated on the fly, usually to represent a single -value in the abstract assembly code (i.e. dynamic registers are usually -single assignment). Ultimately, they are mapped to available machine -registers before spitting out the code. - -\begin{code} +This is the generic register allocator. It does allocation for all +architectures. Details for specific architectures are given in +RegAllocInfo.lhs. In practice the allocator needs to know next to +nothing about an architecture to do its job: -data Reg = FixedReg FAST_INT -- A pre-allocated machine register - - | MappedReg FAST_INT -- A dynamically allocated machine register - - | MemoryReg Int PrimRep -- A machine "register" actually held in a memory - -- allocated table of registers which didn't fit - -- in real registers. - - | UnmappedReg Unique PrimRep -- One of an infinite supply of registers, - -- always mapped to one of the earlier two - -- before we're done. - -- No thanks: deriving (Eq) - -mkReg :: Unique -> PrimRep -> Reg -mkReg = UnmappedReg - -instance Text Reg where - showsPrec _ (FixedReg i) = showString "%" . shows IBOX(i) - showsPrec _ (MappedReg i) = showString "%" . shows IBOX(i) - showsPrec _ (MemoryReg i _) = showString "%M" . shows i - showsPrec _ (UnmappedReg i _) = showString "%U" . shows i - -#ifdef DEBUG -instance Outputable Reg where - ppr sty r = ppStr (show r) -#endif - -cmpReg (FixedReg i) (FixedReg i') = cmp_ihash i i' -cmpReg (MappedReg i) (MappedReg i') = cmp_ihash i i' -cmpReg (MemoryReg i _) (MemoryReg i' _) = cmp_i i i' -cmpReg (UnmappedReg u _) (UnmappedReg u' _) = cmp u u' -cmpReg r1 r2 = - let tag1 = tagReg r1 - tag2 = tagReg r2 - in - if tag1 _LT_ tag2 then LT_ else GT_ - where - tagReg (FixedReg _) = (ILIT(1) :: FAST_INT) - tagReg (MappedReg _) = ILIT(2) - tagReg (MemoryReg _ _) = ILIT(3) - tagReg (UnmappedReg _ _) = ILIT(4) - -cmp_i :: Int -> Int -> TAG_ -cmp_i a1 a2 = if a1 == a2 then EQ_ else if a1 < a2 then LT_ else GT_ - -cmp_ihash :: FAST_INT -> FAST_INT -> TAG_ -cmp_ihash a1 a2 = if a1 _EQ_ a2 then EQ_ else if a1 _LT_ a2 then LT_ else GT_ - -instance Eq Reg where - a == b = case cmpReg a b of { EQ_ -> True; _ -> False } - a /= b = case cmpReg a b of { EQ_ -> False; _ -> True } - -instance Ord Reg where - a <= b = case cmpReg a b of { LT_ -> True; EQ_ -> True; GT__ -> False } - a < b = case cmpReg a b of { LT_ -> True; EQ_ -> False; GT__ -> False } - a >= b = case cmpReg a b of { LT_ -> False; EQ_ -> True; GT__ -> True } - a > b = case cmpReg a b of { LT_ -> False; EQ_ -> False; GT__ -> True } - _tagCmp a b = case cmpReg a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT } - -instance NamedThing Reg where - -- the *only* method that should be defined is "getItsUnique"! - -- (so we can use UniqFMs/UniqSets on Regs - getItsUnique (UnmappedReg u _) = u - getItsUnique (FixedReg i) = mkPseudoUnique1 IBOX(i) - getItsUnique (MappedReg i) = mkPseudoUnique2 IBOX(i) - getItsUnique (MemoryReg i _) = mkPseudoUnique3 i -\end{code} +* It needs to be given a list of the registers it can allocate to. -This is the generic register allocator. +* It needs to be able to find out which registers each insn reads and + writes. -%************************************************************************ -%* * -\subsection[RegPlace]{Map Stix registers to {\em real} registers} -%* * -%************************************************************************ +* It needs be able to change registers in instructions into other + registers. -An important point: The @regUsage@ function for a particular assembly language -must not refer to fixed registers, such as Hp, SpA, etc. The source and destination -lists should only refer to dynamically allocated registers or static registers -from the free list. As far as we are concerned, the fixed registers simply don't -exist (for allocation purposes, anyway). +* It needs to be able to find out where execution could go after an + in instruction. -\begin{code} +* It needs to be able to discover sets of registers which can be + used to attempt spilling. -class MachineRegisters a where - mkMRegs :: [Int] -> a - possibleMRegs :: PrimRep -> a -> [Int] - useMReg :: a -> FAST_INT -> a - useMRegs :: a -> [Int] -> a - freeMReg :: a -> FAST_INT -> a - freeMRegs :: a -> [Int] -> a - -type RegAssignment = FiniteMap Reg Reg -type RegConflicts = FiniteMap Int (UniqSet Reg) - -data FutureLive - = FL (UniqSet Reg) - (FiniteMap CLabel (UniqSet Reg)) -fstFL (FL a b) = a - -data RegHistory a - = RH a - Int - RegAssignment - -data RegFuture - = RF (UniqSet Reg) -- in use - FutureLive -- future - RegConflicts - -data RegInfo a - = RI (UniqSet Reg) -- in use - (UniqSet Reg) -- sources - (UniqSet Reg) -- destinations - [Reg] -- last used - RegConflicts - -data RegUsage - = RU (UniqSet Reg) - (UniqSet Reg) - -data RegLiveness - = RL (UniqSet Reg) - FutureLive - -class MachineCode a where - regUsage :: a -> RegUsage - regLiveness :: a -> RegLiveness -> RegLiveness - patchRegs :: a -> (Reg -> Reg) -> a - spillReg :: Reg -> Reg -> OrdList a - loadReg :: Reg -> Reg -> OrdList a -\end{code} - -First we try something extremely simple. -If that fails, we have to do things the hard way. +First we try something extremely simple. If that fails, we have to do +things the hard way. \begin{code} runRegAllocate - :: (MachineRegisters a, MachineCode b) - => a - -> [Int] - -> (OrdList b) - -> [b] + :: [Reg] + -> ([Instr] -> [[Reg]]) + -> InstrBlock + -> [Instr] -runRegAllocate regs reserve_regs instrs = +runRegAllocate regs find_reserve_regs instrs + = --trace ("runRegAllocate: " ++ show regs) ( case simpleAlloc of - Just x -> x - Nothing -> hairyAlloc - where - flatInstrs = flattenOrdList instrs - simpleAlloc = simpleRegAlloc regs [] emptyFM flatInstrs - hairyAlloc = hairyRegAlloc regs reserve_regs flatInstrs - -runHairyRegAllocate -- use only hairy for i386! - :: (MachineRegisters a, MachineCode b) - => a - -> [Int] - -> (OrdList b) - -> [b] - -runHairyRegAllocate regs reserve_regs instrs - = hairyRegAlloc regs reserve_regs flatInstrs + Just simple -> --trace "SIMPLE" + simple + Nothing -> --trace "GENERAL" + (tryGeneral reserves) + --) where - flatInstrs = flattenOrdList instrs + tryGeneral [] + = pprPanic "nativeGen: spilling failed. Workaround: compile with -fvia-C.\n" + ( (text "reserves = " <> ppr reserves) + $$ + (text "code = ") + $$ + (vcat (map (docToSDoc.pprInstr) flatInstrs)) + ) + tryGeneral (resv:resvs) + = case generalAlloc resv of + Just success -> success + Nothing -> tryGeneral resvs + + reserves = find_reserve_regs flatInstrs + flatInstrs = fromOL instrs + simpleAlloc = doSimpleAlloc regs flatInstrs + generalAlloc resvd = doGeneralAlloc regs resvd flatInstrs \end{code} -Here is the simple register allocator. Just dole out registers until -we run out, or until one gets clobbered before its last use. Don't -do anything fancy with branches. Just pretend that you've got a block -of straight-line code and hope for the best. Experience indicates that -this approach will suffice for about 96 percent of the code blocks that -we generate. - -\begin{code} - -simpleRegAlloc - :: (MachineRegisters a, MachineCode b) - => a -- registers to select from - -> [Reg] -- live static registers - -> RegAssignment -- mapping of dynamics to statics - -> [b] -- code - -> Maybe [b] - -simpleRegAlloc _ _ _ [] = Just [] -simpleRegAlloc free live env (instr:instrs) = - if null deadSrcs && maybeToBool newAlloc && maybeToBool instrs2 then - Just (instr3 : instrs3) - else - Nothing - where - instr3 = patchRegs instr (lookup env2) - - (srcs, dsts) = case regUsage instr of { RU s d -> (uniqSetToList s, uniqSetToList d) } - - lookup env x = case lookupFM env x of {Just y -> y; Nothing -> x} - - deadSrcs = [r | r@(UnmappedReg _ _) <- srcs, lookup env r `not_elem` live] - newDsts = [r | r@(UnmappedReg _ _) <- dsts, r `not_elem` keysFM env] - - newAlloc = foldr allocateNewReg (Just (free, [])) newDsts - (free2, new) = case newAlloc of Just x -> x +Rather than invoke the heavyweight machinery in @doGeneralAlloc@ for +each and every code block, we first try using this simple, fast and +utterly braindead allocator. In practice it handles about 60\% of the +code blocks really fast, even with only 3 integer registers available. +Since we can always give up and fall back to @doGeneralAlloc@, +@doSimpleAlloc@ is geared to handling the common case as fast as +possible. It will succeed only if: - env2 = env `addListToFM` new +* The code mentions registers only of integer class, not floating + class. - live2 = map snd new ++ [x | x <- live, x `not_elem` dsts] +* The code doesn't mention any real registers, so we don't have to + think about dodging and weaving to work around fixed register uses. - instrs2 = simpleRegAlloc free2 live2 env2 instrs - instrs3 = case instrs2 of Just x -> x +* The code mentions at most N virtual registers, where N is the number + of real registers for allocation. - allocateNewReg - :: MachineRegisters a - => Reg - -> Maybe (a, [(Reg, Reg)]) - -> Maybe (a, [(Reg, Reg)]) - - allocateNewReg _ Nothing = Nothing - - allocateNewReg d@(UnmappedReg _ pk) (Just (free, prs)) = - if null choices then Nothing - else Just (free2, prs2) - where - choices = possibleMRegs pk free - reg = head choices - free2 = free `useMReg` (case reg of {IBOX(reg2) -> reg2} ) - prs2 = ((d, MappedReg (case reg of {IBOX(reg2) -> reg2})) : prs) +If those conditions are satisfied, we simply trundle along the code, +doling out a real register every time we see mention of a new virtual +register. We either succeed at this, or give up when one of the above +three conditions is no longer satisfied. +\begin{code} +doSimpleAlloc :: [Reg] -> [Instr] -> Maybe [Instr] +doSimpleAlloc available_real_regs instrs + = let available_iregs + = filter ((== RcInteger).regClass) available_real_regs + + trundle :: [( {-Virtual-}Reg, {-Real-}Reg )] + -> [ {-Real-}Reg ] + -> [Instr] + -> [Instr] + -> Maybe [Instr] + trundle vreg_map uncommitted_rregs ris_done [] + = Just (reverse ris_done) + trundle vreg_map uncommitted_rregs ris_done (i:is) + = case regUsage i of + RU rds wrs + + -- Mentions no regs? Move on quickly + | null rds_l && null wrs_l + -> trundle vreg_map uncommitted_rregs (i:ris_done) is + + -- A case we can't be bothered to handle? + | any isFloatingOrReal rds_l || any isFloatingOrReal wrs_l + -> Nothing + + -- Update the rreg commitments, and map the insn + | otherwise + -> case upd_commitment (wrs_l++rds_l) + vreg_map uncommitted_rregs of + Nothing -- out of rregs; give up + -> Nothing + Just (vreg_map2, uncommitted_rregs2) + -> let i2 = patchRegs i (subst_reg vreg_map2) + in trundle vreg_map2 uncommitted_rregs2 + (i2:ris_done) is + where + isFloatingOrReal reg + = isRealReg reg || regClass reg == RcFloat + || regClass reg == RcDouble + + rds_l = regSetToList rds + wrs_l = regSetToList wrs + + upd_commitment [] vr_map uncomm + = Just (vr_map, uncomm) + upd_commitment (reg:regs) vr_map uncomm + | isRealReg reg + = upd_commitment regs vr_map uncomm + | reg `elem` (map fst vr_map) + = upd_commitment regs vr_map uncomm + | null uncomm + = Nothing + | otherwise + = upd_commitment regs ((reg, head uncomm):vr_map) + (tail uncomm) + + subst_reg vreg_map r + -- If it's a RealReg, it must be STG-specific one + -- (Hp,Sp,BaseReg,etc), since regUsage filters them out, + -- so isFloatingOrReal would not have objected to it. + | isRealReg r + = r + | otherwise + = case [rr | (vr,rr) <- vreg_map, vr == r] of + [rr2] -> rr2 + other -> pprPanic + "doSimpleAlloc: unmapped VirtualReg" + (ppr r) + in + trundle [] available_iregs [] instrs \end{code} -Here is the ``clever'' bit. First go backward (i.e. left), looking for -the last use of dynamic registers. Then go forward (i.e. right), filling -registers with static placements. +From here onwards is the general register allocator and spiller. For +each flow edge (possible transition between instructions), we compute +which virtual and real registers are live on that edge. Then the +mapping is inverted, to give a mapping from register (virtual+real) to +sets of flow edges on which the register is live. Finally, we can use +those sets to decide whether a virtual reg v can be assigned to a real +reg r, by checking that v's live-edge-set does not intersect with r's +current live-edge-set. Having made that assignment, we then augment +r's current live-edge-set (its current commitment, you could say) with +v's live-edge-set. + +doGeneralAlloc takes reserve_regs as the regs to use as spill +temporaries. First it tries to allocate using all regs except +reserve_regs. If that fails, it inserts spill code and tries again to +allocate regs, but this time with the spill temporaries available. +Even this might not work if there are insufficient spill temporaries: +in the worst case on x86, we'd need 3 of them, for insns like addl +(%reg1,%reg2,4) %reg3, since this insn uses all 3 regs as input. \begin{code} - -hairyRegAlloc - :: (MachineRegisters a, MachineCode b) - => a - -> [Int] - -> [b] - -> [b] - -hairyRegAlloc regs reserve_regs instrs = - case mapAccumB (doRegAlloc reserve_regs) - (RH regs' 1 emptyFM) noFuture instrs - of (RH _ loc' _, _, instrs') -> - if loc' == 1 then instrs' else - case mapAccumB do_RegAlloc_Nil - (RH regs'' loc' emptyFM) noFuture (flattenOrdList (patchMem instrs')) - of ((RH _ loc'' _),_,instrs'') -> - if loc'' == loc' then instrs'' else panic "runRegAllocate" - where - regs' = regs `useMRegs` reserve_regs - regs'' = mkMRegs reserve_regs `asTypeOf` regs - -do_RegAlloc_Nil = doRegAlloc [] -- out here to avoid CAF (sigh) -do_RegAlloc_Nil - :: (MachineRegisters a, MachineCode b) - => RegHistory a - -> RegFuture - -> b - -> (RegHistory a, RegFuture, b) - -noFuture :: RegFuture -noFuture = RF emptyUniqSet (FL emptyUniqSet emptyFM) emptyFM +doGeneralAlloc + :: [Reg] -- all allocatable regs + -> [Reg] -- the reserve regs + -> [Instr] -- instrs in + -> Maybe [Instr] -- instrs out + +doGeneralAlloc all_regs reserve_regs instrs + -- succeeded without spilling + | prespill_ok + = Just prespill_insns + + -- failed, and no spill regs avail, so pointless to attempt spilling + | null reserve_regs = Nothing + -- success after spilling + | postspill_ok = maybetrace (spillMsg True) (Just postspill_insns) + -- still not enough reserves after spilling; we have to give up + | otherwise = maybetrace (spillMsg False) Nothing + where + prespill_regs + = filter (`notElem` reserve_regs) all_regs + (prespill_ok, prespill_insns) + = allocUsingTheseRegs instrs prespill_regs + instrs_with_spill_code + = insertSpillCode prespill_insns + (postspill_ok, postspill_insns) + = allocUsingTheseRegs instrs_with_spill_code all_regs + + spillMsg success + = "nativeGen: spilling " + ++ (if success then "succeeded" else "failed ") + ++ " using " + ++ showSDoc (hsep (map ppr reserve_regs)) + +# ifdef NCG_DEBUG + maybetrace msg x = trace msg x +# else + maybetrace msg x = x +# endif \end{code} -Here we patch instructions that reference ``registers'' which are really in -memory somewhere (the mapping is under the control of the machine-specific -code generator). We place the appropriate load sequences before any instructions -that use memory registers as sources, and we place the appropriate spill sequences -after any instructions that use memory registers as destinations. The offending -instructions are rewritten with new dynamic registers, so we have to run register -allocation again after all of this is said and done. +Here we patch instructions that reference ``registers'' which are +really in memory somewhere (the mapping is under the control of the +machine-specific code generator). We place the appropriate load +sequences before any instructions that use memory registers as +sources, and we place the appropriate spill sequences after any +instructions that use memory registers as destinations. The offending +instructions are rewritten with new dynamic registers, so generalAlloc +has to run register allocation again after all of this is said and +done. + +On some architectures (x86, currently), we do without a frame-pointer, +and instead spill relative to the stack pointer (%esp on x86). +Because the stack pointer may move, the patcher needs to keep track of +the current stack pointer "delta". That's easy, because all it needs +to do is spot the DELTA bogus-insns which will have been inserted by +the relevant insn selector precisely so as to notify the spiller of +stack-pointer movement. The delta is passed to loadReg and spillReg, +since they generate the actual spill code. We expect the final delta +to be the same as the starting one (zero), reflecting the fact that +changes to the stack pointer should not extend beyond a basic block. + +Finally, there is the issue of mapping an arbitrary set of unallocated +VirtualRegs into a contiguous sequence of spill slots. The failed +allocation will have left the code peppered with references to +VirtualRegs, each of which contains a unique. So we make an env which +maps these VirtualRegs to integers, starting from zero, and pass that +env through to loadReg and spillReg. There, they are used to look up +spill slot numbers for the uniques. \begin{code} - -patchMem - :: MachineCode a - => [a] - -> OrdList a - -patchMem cs = foldr (mkSeqList . patchMem') mkEmptyList cs - -patchMem' - :: MachineCode a - => a - -> OrdList a - -patchMem' instr = - if null memSrcs && null memDsts then mkUnitList instr - else mkSeqList - (foldr mkParList mkEmptyList loadSrcs) - (mkSeqList instr' - (foldr mkParList mkEmptyList spillDsts)) - - where - (RU srcs dsts) = regUsage instr - - memToDyn (MemoryReg i pk) = UnmappedReg (mkBuiltinUnique i) pk - memToDyn other = other - - memSrcs = [ r | r@(MemoryReg _ _) <- uniqSetToList srcs] - memDsts = [ r | r@(MemoryReg _ _) <- uniqSetToList dsts] - - loadSrcs = map load memSrcs +insertSpillCode :: [Instr] -> [Instr] +insertSpillCode insns + = let uniques_in_insns + = map getVRegUnique + (regSetToList + (foldl unionRegSets emptyRegSet + (map vregs_in_insn insns))) + vregs_in_insn i + = case regUsage i of + RU rds wrs -> filterRegSet isVirtualReg + (rds `unionRegSets` wrs) + vreg_to_slot_map :: FiniteMap VRegUnique Int + vreg_to_slot_map + = listToFM (zip uniques_in_insns [0..]) + + ((final_stack_delta, final_ctr), insnss) + = mapAccumL (patchInstr vreg_to_slot_map) (0,0) insns + in + if final_stack_delta == 0 + then concat insnss + else pprPanic "patchMem: non-zero final delta" + (int final_stack_delta) + + +-- patchInstr has as a running state two Ints, one the current stack delta, +-- needed to figure out offsets to stack slots on archs where we spill relative +-- to the stack pointer, as opposed to the frame pointer. The other is a +-- counter, used to manufacture new temporary register names. + +patchInstr :: FiniteMap VRegUnique Int -> (Int,Int) -> Instr -> ((Int,Int), [Instr]) +patchInstr vreg_to_slot_map (delta,ctr) instr + + | null memSrcs && null memDsts + = ((delta',ctr), [instr]) + + | otherwise + = ((delta',ctr'), loadSrcs ++ [instr'] ++ spillDsts) + where + delta' = case instr of DELTA d -> d ; _ -> delta + + (RU srcs dsts) = regUsage instr + + -- The instr being patched may mention several vregs -- those which + -- could not be assigned real registers. For each such vreg, we + -- invent a new vreg, used only around this instruction and nowhere + -- else. These new vregs replace the unallocatable vregs; they are + -- loaded from the spill area, the instruction is done with them, + -- and results if any are then written back to the spill area. + vregs_in_instr + = nub (filter isVirtualReg + (regSetToList srcs ++ regSetToList dsts)) + n_vregs_in_instr + = length vregs_in_instr + ctr' + = ctr + n_vregs_in_instr + vreg_env + = zip vregs_in_instr [ctr, ctr+1 ..] + + mkTmpReg vreg + | isVirtualReg vreg + = case [vi | (vreg', vi) <- vreg_env, vreg' == vreg] of + [i] -> case regClass vreg of + RcInteger -> VirtualRegI (pseudoVReg i) + RcFloat -> VirtualRegF (pseudoVReg i) + RcDouble -> VirtualRegD (pseudoVReg i) + _ -> pprPanic "patchInstr: unmapped VReg" (ppr vreg) + | otherwise + = vreg + + pseudoVReg i = VRegUniqueLo (mkPseudoUnique3 i) + + memSrcs = filter isVirtualReg (regSetToList srcs) + memDsts = filter isVirtualReg (regSetToList dsts) + + loadSrcs = map load memSrcs spillDsts = map spill memDsts - load mem = loadReg mem (memToDyn mem) - spill mem = spillReg (memToDyn mem) mem - - instr' = mkUnitList (patchRegs instr memToDyn) + load mem = loadReg vreg_to_slot_map delta mem (mkTmpReg mem) + spill mem = spillReg vreg_to_slot_map delta' (mkTmpReg mem) mem + instr' = patchRegs instr mkTmpReg \end{code} +allocUsingTheseRegs is the register allocator proper. It attempts +to allocate dynamic regs to real regs, given a list of real regs +which it may use. If it fails due to lack of real regs, the returned +instructions use what real regs there are, but will retain uses of +dynamic regs for which a real reg could not be found. It is these +leftover dynamic reg references which insertSpillCode will later +assign to spill slots. + +Some implementation notes. +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Instructions are numbered sequentially, starting at zero. + +A flow edge (FE) is a pair of insn numbers (MkFE Int Int) denoting +a possible flow of control from the first insn to the second. + +The input to the register allocator is a list of instructions, which +mention Regs. A Reg can be a RealReg -- a real machine reg -- or a +VirtualReg, which carries a unique. After allocation, all the +VirtualReg references will have been converted into RealRegs, and +possible some spill code will have been inserted. + +The heart of the register allocator works in four phases. + +1. (find_flow_edges) Calculate all the FEs for the code list. + Return them not as a [FE], but implicitly, as a pair of + Array Int [Int], being the successor and predecessor maps + for instructions. + +2. (calc_liveness) Returns a FiniteMap FE RegSet. For each + FE, indicates the set of registers live on that FE. Note + that the set includes both RealRegs and VirtualRegs. The + former appear because the code could mention fixed register + usages, and we need to take them into account from the start. + +3. (calc_live_range_sets) Invert the above mapping, giving a + FiniteMap Reg FeSet, indicating, for each virtual and real + reg mentioned in the code, which FEs it is live on. + +4. (calc_vreg_to_rreg_mapping) For virtual reg, try and find + an allocatable real register for it. Each real register has + a "current commitment", indicating the set of FEs it is + currently live on. A virtual reg v can be assigned to + real reg r iff v's live-fe-set does not intersect with r's + current commitment fe-set. If the assignment is made, + v's live-fe-set is union'd into r's current commitment fe-set. + There is also the minor restriction that v and r must be of + the same register class (integer or floating). + + Once this mapping is established, we simply apply it to the + input insns, and that's it. + + If no suitable real register can be found, the vreg is mapped + to itself, and we deem allocation to have failed. The partially + allocated code is returned. The higher echelons of the allocator + (doGeneralAlloc and runRegAlloc) then cooperate to insert spill + code and re-run allocation, until a successful allocation is found. \begin{code} -doRegAlloc - :: (MachineRegisters a, MachineCode b) - => [Int] - -> RegHistory a - -> RegFuture - -> b - -> (RegHistory a, RegFuture, b) +allocUsingTheseRegs :: [Instr] -> [Reg] -> (Bool, [Instr]) +allocUsingTheseRegs instrs available_real_regs + = let (all_vregs_mapped, v_to_r_mapping) + = calc_vreg_to_rreg_mapping instrs available_real_regs + new_insns + = map (flip patchRegs sr) instrs + sr reg + | isRealReg reg + = reg + | otherwise + = case lookupFM v_to_r_mapping reg of + Just r -> r + Nothing -> pprPanic "allocateUsingTheseRegs: unmapped vreg: " + (ppr reg) + in + --trace ("allocUsingTheseRegs: " ++ show available_real_regs) ( + (all_vregs_mapped, new_insns) + --) + + +-- the heart of the matter. +calc_vreg_to_rreg_mapping :: [Instr] -> [Reg] -> (Bool, FiniteMap Reg Reg) +calc_vreg_to_rreg_mapping insns available_real_regs + = let + lr_sets :: FiniteMap Reg FeSet + lr_sets = calc_live_range_sets insns + + -- lr_sets maps: vregs mentioned in insns to sets of live FEs + -- and also: rregs mentioned in insns to sets of live FEs + -- We need to extract the rreg mapping, and use it as the + -- initial real-register-commitment. Also, add to the initial + -- commitment, empty commitments for any real regs not + -- mentioned in it. + + -- which real regs do we want to keep track of in the running + -- commitment mapping? Precisely the available_real_regs. + -- We don't care about real regs mentioned by insns which are + -- not in this list, since we're not allocating to them. + initial_rr_commitment :: FiniteMap Reg FeSet + initial_rr_commitment + = listToFM [(rreg, + case lookupFM lr_sets rreg of + Nothing -> emptyFeSet + Just fixed_use_fes -> fixed_use_fes + ) + | rreg <- available_real_regs] + + -- These are the vregs for which we actually have to (try to) + -- assign a real register. (ie, the whole reason we're here at all :) + vreg_liveness_list :: [(Reg, FeSet)] + vreg_liveness_list = filter (not.isRealReg.fst) + (fmToList lr_sets) + + -- A loop, which attempts to assign each vreg to a rreg. + loop rr_commitment v_to_r_map [] + = v_to_r_map + loop rr_commitment v_to_r_map ((vreg,vreg_live_fes):not_yet_done) + = let + -- find a real reg which is not live for any of vreg_live_fes + cand_reals + = [rreg + | (rreg,rreg_live_FEs) <- fmToList rr_commitment, + regClass vreg == regClass rreg, + isEmptyFeSet (intersectionFeSets rreg_live_FEs + vreg_live_fes) + ] + in + case cand_reals of + [] -> -- bummer. No register is available. Just go on to + -- the next vreg, mapping the vreg to itself. + loop rr_commitment (addToFM v_to_r_map vreg vreg) + not_yet_done + (r:_) + -> -- Hurrah! Found a free reg of the right class. + -- Now we need to update the RR commitment. + loop rr_commitment2 (addToFM v_to_r_map vreg r) + not_yet_done + where + rr_commitment2 + = addToFM_C unionFeSets rr_commitment r + vreg_live_fes + + -- the final vreg to rreg mapping + vreg_assignment + = loop initial_rr_commitment emptyFM vreg_liveness_list + -- did we succeed in mapping everyone to a real reg? + allocation_succeeded + = all isRealReg (eltsFM vreg_assignment) + in + (allocation_succeeded, vreg_assignment) + + + +-- calculate liveness, then produce the live range info +-- as a mapping of VRegs to the set of FEs on which they are live. +-- The difficult part is inverting the mapping of Reg -> FeSet +-- to produce a mapping FE -> RegSet. + +calc_live_range_sets :: [Instr] -> FiniteMap Reg FeSet +calc_live_range_sets insns + = let + -- this is the "original" (old) mapping + lis :: FiniteMap FE RegSet + lis = calc_liveness insns + + -- establish the totality of reg names mentioned by the + -- insns, by scanning over the insns. + all_mentioned_regs :: RegSet + all_mentioned_regs + = foldl unionRegSets emptyRegSet + (map (\i -> case regUsage i of + RU rds wrs -> unionRegSets rds wrs) + insns) + + -- Initial inverted mapping, from Reg to sets of FEs + initial_imap :: FiniteMap Reg FeSet + initial_imap + = listToFM [(reg, emptyFeSet) + | reg <- regSetToList all_mentioned_regs] + + -- Update the new map with one element of the old map + upd_imap :: FiniteMap Reg FeSet -> (FE, RegSet) + -> FiniteMap Reg FeSet + upd_imap imap (fe, regset) + = foldl upd_1_imap imap (regSetToList regset) + where + upd_1_imap curr reg + = addToFM_C unionFeSets curr reg (unitFeSet fe) + + -- the complete inverse mapping + final_imap :: FiniteMap Reg FeSet + final_imap + = foldl upd_imap initial_imap (fmToList lis) + in + final_imap + + + +-- Given the insns, calculate the FEs, and then doing fixpointing to +-- figure out the set of live regs (virtual regs AND real regs) live +-- on each FE. + +calc_liveness :: [Instr] -> FiniteMap FE RegSet +calc_liveness insns + = let (pred_map, succ_map) + = find_flow_edges insns + + -- We use the convention that if the current approximation + -- doesn't give a mapping for some FE, that FE maps to the + -- empty set. + initial_approx, fixpoint :: FiniteMap FE RegSet + initial_approx + = mk_initial_approx 0 insns succ_map emptyFM + fixpoint + = fix_set initial_approx 1 + -- If you want to live dangerously, and promise that the code + -- doesn't contain any loops (ie, there are no back edges in + -- the flow graph), you should be able to get away with this: + -- = upd_liveness_info pred_map succ_map insn_array initial_approx + -- But since I'm paranoid, and since it hardly makes any difference + -- to the compiler run-time (about 0.1%), I prefer to do the + -- the full fixpointing game. + + insn_array + = let n = length insns + in array (0, n-1) (zip [0..] insns) + + sameSets [] [] = True + sameSets (c:cs) (n:ns) = eqRegSets c n && sameSets cs ns + sameSets _ _ = False + + fix_set curr_approx iter_number + = let next_approx + = upd_liveness_info pred_map succ_map insn_array curr_approx + curr_sets + = eltsFM curr_approx + next_sets + = eltsFM next_approx + same + = sameSets curr_sets next_sets + final_approx + = if same then curr_approx + else fix_set next_approx (iter_number+1) + in + --trace (let qqq (fe, regset) + -- = show fe ++ " " ++ show (regSetToList regset) + -- in + -- "\n::iteration " ++ show iter_number ++ "\n" + -- ++ (unlines . map qqq . fmToList) + -- next_approx ++"\n" + -- ) + final_approx + in + fixpoint + + +-- Create a correct initial approximation. For each instruction that +-- writes a register, we deem that the register is live on the +-- flow edges leaving the instruction. Subsequent iterations of +-- the liveness AbI augment this based purely on reads of regs, not +-- writes. We need to start off with at least this minimal write- +-- based information in order that writes to vregs which are never +-- used have non-empty live ranges. If we don't do that, we eventually +-- wind up assigning such vregs to any old real reg, since they don't +-- apparently conflict -- you can't conflict with an empty live range. +-- This kludge is unfortunate, but we need to do it to cover not only +-- writes to vregs which are never used, but also to deal correctly +-- with the fact that calls to C will trash the callee saves registers. + +mk_initial_approx :: Int -> [Instr] -> Array Int [Int] + -> FiniteMap FE RegSet + -> FiniteMap FE RegSet +mk_initial_approx ino [] succ_map ia_so_far + = ia_so_far +mk_initial_approx ino (i:is) succ_map ia_so_far + = let wrs + = case regUsage i of RU rrr www -> www + new_fes + = [case iUnbox ino of { inoh -> + case iUnbox ino_succ of { ino_succh -> + MkFE inoh ino_succh + }} + | ino_succ <- succ_map ! ino] + + loop [] ia = ia + loop (fe:fes) ia + = loop fes (addToFM_C unionRegSets ia fe wrs) + + next_ia + = loop new_fes ia_so_far + in + mk_initial_approx (ino+1) is succ_map next_ia + + +-- Do one step in the liveness info calculation (AbI :). Given the +-- prior approximation (which tells you a subset of live VRegs+RRegs +-- for each flow edge), calculate new information for all FEs. +-- Rather than do this by iterating over FEs, it's easier to iterate +-- over insns, and update their incoming FEs. + +upd_liveness_info :: Array Int [Int] -- instruction pred map + -> Array Int [Int] -- instruction succ map + -> Array Int Instr -- array of instructions + -> FiniteMap FE RegSet -- previous approx + -> FiniteMap FE RegSet -- improved approx + +upd_liveness_info pred_map succ_map insn_array prev_approx + = do_insns hi prev_approx + where + (lo, hi) = bounds insn_array + + enquireMapFE :: FiniteMap FE RegSet -> FE + -> RegSet + enquireMapFE fm fe + = case lookupFM fm fe of + Just set -> set + Nothing -> emptyRegSet + + -- Work backwards, from the highest numbered insn to the lowest. + -- This is a heuristic which causes faster convergence to the + -- fixed point. In particular, for straight-line code with no + -- branches at all, arrives at the fixpoint in one iteration. + do_insns ino approx + | ino < lo + = approx + | otherwise + = let fes_to_futures + = [case iUnbox ino of { inoh -> + case iUnbox future_ino of { future_inoh -> + MkFE inoh future_inoh + }} + | future_ino <- succ_map ! ino] + future_lives + = map (enquireMapFE approx) fes_to_futures + future_live + = foldr unionRegSets emptyRegSet future_lives + + fes_from_histories + = [case iUnbox history_ino of { history_inoh -> + case iUnbox ino of { inoh -> + MkFE history_inoh inoh + }} + | history_ino <- pred_map ! ino] + new_approx + = foldl update_one_history approx fes_from_histories + + insn + = insn_array ! ino + history_independent_component + = case regUsage insn of + RU rds wrs + -> unionRegSets rds + (minusRegSets future_live wrs) + + update_one_history :: FiniteMap FE RegSet + -> FE + -> FiniteMap FE RegSet + update_one_history approx0 fe + = addToFM_C unionRegSets approx0 fe + history_independent_component + + rest_done + = do_insns (ino-1) new_approx + in + rest_done + + + +-- Extract the flow edges from a list of insns. Express the information +-- as two mappings, from insn number to insn numbers of predecessors, +-- and from insn number to insn numbers of successors. (Since that's +-- what we need to know when computing live ranges later). Instructions +-- are numbered starting at zero. This function is long and complex +-- in order to be efficient; it could equally well be shorter and slower. + +find_flow_edges :: [Instr] -> (Array Int [Int], + Array Int [Int]) +find_flow_edges insns + = let + -- First phase: make a temp env which maps labels + -- to insn numbers, so the second pass can know the insn + -- numbers for jump targets. + + label_env :: FiniteMap CLabel Int + + mk_label_env n env [] = env + mk_label_env n env ((LABEL clbl):is) + = mk_label_env (n+1) (addToFM env clbl n) is + mk_label_env n env (i:is) + = mk_label_env (n+1) env is + + label_env = mk_label_env 0 emptyFM insns + + find_label :: CLabel -> Int + find_label jmptarget + = case lookupFM label_env jmptarget of + Just ino -> ino + Nothing -> pprPanic "find_flow_edges: unmapped label" + (pprCLabel jmptarget) + + -- Second phase: traverse the insns, and make up the successor map. + + least_ino, greatest_ino :: Int + least_ino = 0 + greatest_ino = length insns - 1 + + mk_succ_map :: Int -> [(Int, [Int])] -> [Instr] -> [(Int, [Int])] + + mk_succ_map i_num rsucc_map [] + = reverse rsucc_map + + mk_succ_map i_num rsucc_map (i:is) + = let i_num_1 = i_num + 1 + in + case insnFuture i of + + NoFuture + -> -- A non-local jump. We can regard this insn as a terminal + -- insn in the graph, so we don't add any edges. + mk_succ_map i_num_1 ((i_num,[]):rsucc_map) is + + Next + | null is -- this is the last insn, and it doesn't go anywhere + -- (a meaningless scenario); handle it anyway + -> mk_succ_map i_num_1 ((i_num,[]):rsucc_map) is + + | otherwise -- flows to next insn; add fe i_num -> i_num+1 + -> mk_succ_map i_num_1 ((i_num, [i_num_1]): rsucc_map) + is + + Branch lab -- jmps to lab; add fe i_num -> i_target + -> let i_target = find_label lab + in + mk_succ_map i_num_1 ((i_num, [i_target]): rsucc_map) is + + NextOrBranch lab + | null is -- jmps to label, or falls through, and this is + -- the last insn (a meaningless scenario); + -- flag an error + -> error "find_flow_edges: NextOrBranch is last" + + | otherwise -- add fes i_num -> i_num+1 + -- and i_num -> i_target + -> let i_target = find_label lab + in + mk_succ_map i_num_1 ((i_num, [i_num_1, i_target]):rsucc_map) + is + MultiFuture labels + -> -- A jump, whose targets are listed explicitly. + -- (Generated from table-based switch translations). + -- Add fes i_num -> x for each x in labels + let is_target = nub (map find_label labels) + in + mk_succ_map i_num_1 ((i_num, is_target):rsucc_map) is + + -- Third phase: invert the successor map to get the predecessor + -- map, using an algorithm which is quadratic in the worst case, + -- but runs in almost-linear time, because of the nature of our + -- inputs: most insns have a single successor, the next insn. + + invert :: [(Int, [Int])] -> [(Int, [Int])] + invert fmap + = let inverted_pairs + = concatMap ( \ (a, bs) -> [(b,a) | b <- bs] ) fmap + sorted_inverted_pairs + = isort inverted_pairs + + grp :: Int -> [Int] -> [(Int,Int)] -> [(Int,[Int])] + grp k vs [] = [(k, vs)] + grp k vs ((kk,vv):rest) + | k == kk = grp k (vv:vs) rest + | otherwise = (k,vs) : grp kk [vv] rest + + grp_start [] = [] + grp_start ((kk,vv):rest) = grp kk [vv] rest + + grouped + = grp_start sorted_inverted_pairs + + -- make sure that the reverse mapping maps all inos + add_empties ino [] + | ino > greatest_ino = [] + | otherwise = (ino,[]): add_empties (ino+1) [] + add_empties ino ((k,vs):rest) + | ino < k = (ino,[]): add_empties (ino+1) ((k,vs):rest) + | ino == k = (k,vs) : add_empties (ino+1) rest + + -- This is nearly linear provided that the fsts of the + -- list are nearly in order -- a critical assumption + -- for efficiency. + isort :: [(Int,Int)] -> [(Int,Int)] + isort [] = [] + isort (x:xs) = insert x (isort xs) + + insert :: (Int,Int) -> [(Int,Int)] -> [(Int,Int)] + insert y [] = [y] + insert y (z:zs) + -- specifically, this first test should almost always + -- be True in order for the near-linearity to happen + | fst y <= fst z = y:z:zs + | otherwise = z: insert y zs + in + add_empties least_ino grouped + + -- Finally ... + + succ_list + = mk_succ_map 0 [] insns + succ_map + = array (least_ino, greatest_ino) succ_list + pred_list + = invert succ_list + pred_map + = array (least_ino, greatest_ino) pred_list + in + (pred_map, succ_map) + + +-- That's all, folks! From here on is just some dull supporting stuff. + +-- A data type for flow edges +data FE + = MkFE FastInt FastInt deriving (Eq, Ord) + +-- deriving Show on types with unboxed fields doesn't work +instance Show FE where + showsPrec _ (MkFE s d) + = showString "MkFE" . shows (iBox s) . shows ' ' . shows (iBox d) + +-- Blargh. Use ghc stuff soon! Or: perhaps that's not such a good +-- idea. Most of these sets are either empty or very small, and it +-- might be that the overheads of the FiniteMap based set implementation +-- is a net loss. The same might be true of RegSets. + +newtype FeSet = MkFeSet [FE] + +feSetFromList xs + = MkFeSet (nukeDups (sort xs)) + where nukeDups :: [FE] -> [FE] + nukeDups [] = [] + nukeDups [x] = [x] + nukeDups (x:y:xys) + = if x == y then nukeDups (y:xys) + else x : nukeDups (y:xys) + +feSetToList (MkFeSet xs) = xs +isEmptyFeSet (MkFeSet xs) = null xs +emptyFeSet = MkFeSet [] +eqFeSet (MkFeSet xs1) (MkFeSet xs2) = xs1 == xs2 +unitFeSet x = MkFeSet [x] + +elemFeSet x (MkFeSet xs) + = f xs + where + f [] = False + f (y:ys) | x == y = True + | x < y = False + | otherwise = f ys + +unionFeSets (MkFeSet xs1) (MkFeSet xs2) + = MkFeSet (f xs1 xs2) + where + f [] bs = bs + f as [] = as + f (a:as) (b:bs) + | a < b = a : f as (b:bs) + | a > b = b : f (a:as) bs + | otherwise = a : f as bs + +minusFeSets (MkFeSet xs1) (MkFeSet xs2) + = MkFeSet (f xs1 xs2) + where + f [] bs = [] + f as [] = as + f (a:as) (b:bs) + | a < b = a : f as (b:bs) + | a > b = f (a:as) bs + | otherwise = f as bs + +intersectionFeSets (MkFeSet xs1) (MkFeSet xs2) + = MkFeSet (f xs1 xs2) + where + f [] bs = [] + f as [] = [] + f (a:as) (b:bs) + | a < b = f as (b:bs) + | a > b = f (a:as) bs + | otherwise = a : f as bs -doRegAlloc reserved_regs free_env in_use instr = (free_env', in_use', instr') - where - (free_env', instr') = doRegAlloc' reserved_regs free_env info instr - (in_use', info) = getUsage in_use instr - -\end{code} - -\begin{code} - -getUsage - :: MachineCode a - => RegFuture - -> a - -> (RegFuture, RegInfo a) - -getUsage (RF next_in_use future reg_conflicts) instr = - (RF in_use' future' reg_conflicts', - RI in_use' srcs dsts last_used reg_conflicts') - where (RU srcs dsts) = regUsage instr - (RL in_use future') = regLiveness instr (RL next_in_use future) - live_through = in_use `minusUniqSet` dsts - last_used = [ r | r <- uniqSetToList srcs, - not (r `elementOfUniqSet` (fstFL future) || r `elementOfUniqSet` in_use)] - in_use' = srcs `unionUniqSets` live_through - reg_conflicts' = case new_conflicts of - [] -> reg_conflicts - _ -> addListToFM reg_conflicts new_conflicts - new_conflicts = if isEmptyUniqSet live_dynamics then [] - else [ (r, merge_conflicts r) - | r <- extractMappedRegNos (uniqSetToList dsts) ] - merge_conflicts reg = case lookupFM reg_conflicts reg of - Nothing -> live_dynamics - Just conflicts -> conflicts `unionUniqSets` live_dynamics - live_dynamics = mkUniqSet - [ r | r@(UnmappedReg _ _) <- uniqSetToList live_through ] - -doRegAlloc' - :: (MachineRegisters a, MachineCode b) - => [Int] - -> RegHistory a - -> RegInfo b - -> b - -> (RegHistory a, b) - -doRegAlloc' reserved (RH frs loc env) (RI in_use srcs dsts lastu conflicts) instr = - - (RH frs'' loc' env'', patchRegs instr dynToStatic) - - where - - -- free up new registers - free :: [Int] - free = extractMappedRegNos (map dynToStatic lastu) - - -- (1) free registers that are used last as source operands in this instruction - frs_not_in_use = frs `useMRegs` (extractMappedRegNos (uniqSetToList in_use)) - frs' = (frs_not_in_use `freeMRegs` free) `useMRegs` reserved - - -- (2) allocate new registers for the destination operands - -- allocate registers for new dynamics - - new_dynamix = [ r | r@(UnmappedReg _ _) <- uniqSetToList dsts, r `not_elem` keysFM env ] - - (frs'', loc', new) = foldr allocateNewRegs (frs', loc, []) new_dynamix - - env' = addListToFM env new - - env'' = delListFromFM env' lastu - - dynToStatic :: Reg -> Reg - dynToStatic dyn@(UnmappedReg _ _) = - case lookupFM env' dyn of - Just r -> r - Nothing -> trace "Lost register; possibly a floating point type error in a _ccall_?" dyn - dynToStatic other = other - - allocateNewRegs - :: MachineRegisters a - => Reg -> (a, Int, [(Reg, Reg)]) -> (a, Int, [(Reg, Reg)]) - - allocateNewRegs d@(UnmappedReg _ pk) (fs, mem, lst) = (fs', mem', (d, f) : lst) - where (fs', f, mem') = case acceptable fs of - [] -> (fs, MemoryReg mem pk, mem + 1) - (IBOX(x2):_) -> (fs `useMReg` x2, MappedReg x2, mem) - - acceptable regs = filter no_conflict (possibleMRegs pk regs) - no_conflict reg = case lookupFM conflicts reg of - Nothing -> True - Just conflicts -> not (d `elementOfUniqSet` conflicts) -\end{code} - -\begin{code} -extractMappedRegNos :: [Reg] -> [Int] - -extractMappedRegNos regs - = foldr ex [] regs - where - ex (MappedReg i) acc = IBOX(i) : acc -- we'll take it - ex _ acc = acc -- leave it out -\end{code} - -We keep a local copy of the Prelude function \tr{notElem}, -so that it can be specialised. (Hack me gently. [WDP 94/11]) -\begin{code} -not_elem x [] = True -not_elem x (y:ys) = x /= y && not_elem x ys \end{code}