Remove the old codegen

Except for CgUtils.fixStgRegisters that is used in the NCG and LLVM
backends, and should probably be moved somewhere else.

1 files changed, 0 insertions, 414 deletions

diff --git a/compiler/codeGen/CgCallConv.hs b/compiler/codeGen/CgCallConv.hs
deleted file mode 100644
index e4095fd027..0000000000
--- a/compiler/codeGen/CgCallConv.hs
+++ /dev/null
@@ -1,414 +0,0 @@
------------------------------------------------------------------------------
---
--- (c) The University of Glasgow 2004-2006
---
--- CgCallConv
---
--- The datatypes and functions here encapsulate the
--- calling and return conventions used by the code generator.
---
------------------------------------------------------------------------------
-
-module CgCallConv (
-        -- Argument descriptors
-        mkArgDescr,
-
-        -- Liveness
-        mkRegLiveness,
-
-        -- Register assignment
-        assignCallRegs, assignReturnRegs, assignPrimOpCallRegs,
-
-        -- Calls
-        constructSlowCall, slowArgs, slowCallPattern,
-
-        -- Returns
-        dataReturnConvPrim,
-        getSequelAmode
-    ) where
-
-import CgMonad
-import CgProf
-import SMRep
-
-import OldCmm
-import CLabel
-
-import CgStackery
-import ClosureInfo( CgRep(..), nonVoidArg, idCgRep, cgRepSizeW, isFollowableArg )
-import OldCmmUtils
-import Maybes
-import Id
-import Name
-import Util
-import DynFlags
-import Module
-import FastString
-import Outputable
-import Platform
-import Data.Bits
-
--------------------------------------------------------------------------
---
---      Making argument descriptors
---
---  An argument descriptor describes the layout of args on the stack,
---  both for    * GC (stack-layout) purposes, and
---              * saving/restoring registers when a heap-check fails
---
--- Void arguments aren't important, therefore (contrast constructSlowCall)
---
--------------------------------------------------------------------------
-
--- bring in ARG_P, ARG_N, etc.
-#include "../includes/rts/storage/FunTypes.h"
-
--------------------------
-mkArgDescr :: Name -> [Id] -> FCode ArgDescr
-mkArgDescr _nm args
-  = do dflags <- getDynFlags
-       let arg_bits = argBits dflags arg_reps
-           arg_reps = filter nonVoidArg (map idCgRep args)
-           -- Getting rid of voids eases matching of standard patterns
-       case stdPattern arg_reps of
-           Just spec_id -> return (ArgSpec spec_id)
-           Nothing      -> return (ArgGen arg_bits)
-
-argBits :: DynFlags -> [CgRep] -> [Bool]    -- True for non-ptr, False for ptr
-argBits _      []              = []
-argBits dflags (PtrArg : args) = False : argBits dflags args
-argBits dflags (arg    : args) = take (cgRepSizeW dflags arg) (repeat True) ++ argBits dflags args
-
-stdPattern :: [CgRep] -> Maybe Int
-stdPattern reps
-    = case reps of
-      []          -> Just ARG_NONE  -- just void args, probably
-
-      [PtrArg]    -> Just ARG_P
-      [FloatArg]  -> Just ARG_F
-      [DoubleArg] -> Just ARG_D
-      [LongArg]   -> Just ARG_L
-      [NonPtrArg] -> Just ARG_N
-
-      [NonPtrArg,NonPtrArg] -> Just ARG_NN
-      [NonPtrArg,PtrArg]    -> Just ARG_NP
-      [PtrArg,NonPtrArg]    -> Just ARG_PN
-      [PtrArg,PtrArg]       -> Just ARG_PP
-
-      [NonPtrArg,NonPtrArg,NonPtrArg] -> Just ARG_NNN
-      [NonPtrArg,NonPtrArg,PtrArg]    -> Just ARG_NNP
-      [NonPtrArg,PtrArg,NonPtrArg]    -> Just ARG_NPN
-      [NonPtrArg,PtrArg,PtrArg]       -> Just ARG_NPP
-      [PtrArg,NonPtrArg,NonPtrArg]    -> Just ARG_PNN
-      [PtrArg,NonPtrArg,PtrArg]       -> Just ARG_PNP
-      [PtrArg,PtrArg,NonPtrArg]       -> Just ARG_PPN
-      [PtrArg,PtrArg,PtrArg]          -> Just ARG_PPP
-
-      [PtrArg,PtrArg,PtrArg,PtrArg]               -> Just ARG_PPPP
-      [PtrArg,PtrArg,PtrArg,PtrArg,PtrArg]        -> Just ARG_PPPPP
-      [PtrArg,PtrArg,PtrArg,PtrArg,PtrArg,PtrArg] -> Just ARG_PPPPPP
-      _ -> Nothing
-
-
--------------------------------------------------------------------------
---
---              Bitmap describing register liveness
---              across GC when doing a "generic" heap check
---              (a RET_DYN stack frame).
---
--- NB. Must agree with these macros (currently in StgMacros.h):
--- GET_NON_PTRS(), GET_PTRS(), GET_LIVENESS().
--------------------------------------------------------------------------
-
-mkRegLiveness :: DynFlags -> [(Id, GlobalReg)] -> Int -> Int -> StgWord
-mkRegLiveness dflags regs ptrs nptrs
-  = (toStgWord dflags (toInteger nptrs) `shiftL` 16) .|.
-    (toStgWord dflags (toInteger ptrs)  `shiftL` 24) .|.
-    all_non_ptrs `xor` toStgWord dflags (reg_bits regs)
-  where
-    all_non_ptrs = toStgWord dflags 0xff
-
-    reg_bits [] = 0
-    reg_bits ((id, VanillaReg i _) : regs) | isFollowableArg (idCgRep id)
-        = (1 `shiftL` (i - 1)) .|. reg_bits regs
-    reg_bits (_ : regs)
-        = reg_bits regs
-
--------------------------------------------------------------------------
---
---              Pushing the arguments for a slow call
---
--------------------------------------------------------------------------
-
--- For a slow call, we must take a bunch of arguments and intersperse
--- some stg_ap_<pattern>_ret_info return addresses.
-constructSlowCall
-        :: [(CgRep,CmmExpr)]
-        -> (CLabel,             -- RTS entry point for call
-           [(CgRep,CmmExpr)],   -- args to pass to the entry point
-           [(CgRep,CmmExpr)])   -- stuff to save on the stack
-
-   -- don't forget the zero case
-constructSlowCall []
-  = (mkRtsApFastLabel (fsLit "stg_ap_0"), [], [])
-
-constructSlowCall amodes
-  = (stg_ap_pat, these, rest)
-  where
-    stg_ap_pat = mkRtsApFastLabel arg_pat
-    (arg_pat, these, rest) = matchSlowPattern amodes
-
--- | 'slowArgs' takes a list of function arguments and prepares them for
--- pushing on the stack for "extra" arguments to a function which requires
--- fewer arguments than we currently have.
-slowArgs :: DynFlags -> [(CgRep,CmmExpr)] -> [(CgRep,CmmExpr)]
-slowArgs _ [] = []
-slowArgs dflags amodes
-  | gopt Opt_SccProfilingOn dflags = save_cccs ++ this_pat ++ slowArgs dflags rest
-  | otherwise                      =              this_pat ++ slowArgs dflags rest
-  where
-    (arg_pat, args, rest) = matchSlowPattern amodes
-    stg_ap_pat = mkCmmRetInfoLabel rtsPackageId arg_pat
-    this_pat   = (NonPtrArg, mkLblExpr stg_ap_pat) : args
-    save_cccs  = [(NonPtrArg, mkLblExpr save_cccs_lbl), (NonPtrArg, curCCS)]
-    save_cccs_lbl = mkCmmRetInfoLabel rtsPackageId (fsLit "stg_restore_cccs")
-
-matchSlowPattern :: [(CgRep,CmmExpr)]
-                 -> (FastString, [(CgRep,CmmExpr)], [(CgRep,CmmExpr)])
-matchSlowPattern amodes = (arg_pat, these, rest)
-  where (arg_pat, n)  = slowCallPattern (map fst amodes)
-        (these, rest) = splitAt n amodes
-
--- These cases were found to cover about 99% of all slow calls:
-slowCallPattern :: [CgRep] -> (FastString, Int)
-slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _) = (fsLit "stg_ap_pppppp", 6)
-slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _)         = (fsLit "stg_ap_ppppp", 5)
-slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: _)     = (fsLit "stg_ap_pppp", 4)
-slowCallPattern (PtrArg: PtrArg: PtrArg: VoidArg: _)    = (fsLit "stg_ap_pppv", 4)
-slowCallPattern (PtrArg: PtrArg: PtrArg: _)             = (fsLit "stg_ap_ppp", 3)
-slowCallPattern (PtrArg: PtrArg: VoidArg: _)            = (fsLit "stg_ap_ppv", 3)
-slowCallPattern (PtrArg: PtrArg: _)                     = (fsLit "stg_ap_pp", 2)
-slowCallPattern (PtrArg: VoidArg: _)                    = (fsLit "stg_ap_pv", 2)
-slowCallPattern (PtrArg: _)                             = (fsLit "stg_ap_p", 1)
-slowCallPattern (VoidArg: _)                            = (fsLit "stg_ap_v", 1)
-slowCallPattern (NonPtrArg: _)                          = (fsLit "stg_ap_n", 1)
-slowCallPattern (FloatArg: _)                           = (fsLit "stg_ap_f", 1)
-slowCallPattern (DoubleArg: _)                          = (fsLit "stg_ap_d", 1)
-slowCallPattern (LongArg: _)                            = (fsLit "stg_ap_l", 1)
-slowCallPattern _                                       = panic "CgStackery.slowCallPattern"
-
--------------------------------------------------------------------------
---
---              Return conventions
---
--------------------------------------------------------------------------
-
-dataReturnConvPrim :: CgRep -> CmmReg
-dataReturnConvPrim PtrArg    = CmmGlobal (VanillaReg 1 VGcPtr)
-dataReturnConvPrim NonPtrArg = CmmGlobal (VanillaReg 1 VNonGcPtr)
-dataReturnConvPrim LongArg   = CmmGlobal (LongReg 1)
-dataReturnConvPrim FloatArg  = CmmGlobal (FloatReg 1)
-dataReturnConvPrim DoubleArg = CmmGlobal (DoubleReg 1)
-dataReturnConvPrim VoidArg   = panic "dataReturnConvPrim: void"
-
-
--- getSequelAmode returns an amode which refers to an info table.  The info
--- table will always be of the RET_(BIG|SMALL) kind.  We're careful
--- not to handle real code pointers, just in case we're compiling for
--- an unregisterised/untailcallish architecture, where info pointers and
--- code pointers aren't the same.
--- DIRE WARNING.
--- The OnStack case of sequelToAmode delivers an Amode which is only
--- valid just before the final control transfer, because it assumes
--- that Sp is pointing to the top word of the return address.  This
--- seems unclean but there you go.
-
-getSequelAmode :: FCode CmmExpr
-getSequelAmode
-  = do  { EndOfBlockInfo virt_sp sequel <- getEndOfBlockInfo
-        ; case sequel of
-            OnStack -> do { dflags <- getDynFlags
-                          ; sp_rel <- getSpRelOffset virt_sp
-                          ; returnFC (CmmLoad sp_rel (bWord dflags)) }
-
-            CaseAlts lbl _ _  -> returnFC (CmmLit (CmmLabel lbl))
-        }
-
--------------------------------------------------------------------------
---
---              Register assignment
---
--------------------------------------------------------------------------
-
---  How to assign registers for
---
---      1) Calling a fast entry point.
---      2) Returning an unboxed tuple.
---      3) Invoking an out-of-line PrimOp.
---
--- Registers are assigned in order.
---
--- If we run out, we don't attempt to assign any further registers (even
--- though we might have run out of only one kind of register); we just
--- return immediately with the left-overs specified.
---
--- The alternative version @assignAllRegs@ uses the complete set of
--- registers, including those that aren't mapped to real machine
--- registers.  This is used for calling special RTS functions and PrimOps
--- which expect their arguments to always be in the same registers.
-
-type AssignRegs a = [(CgRep,a)]          -- Arg or result values to assign
-                 -> ([(a, GlobalReg)],   -- Register assignment in same order
-                                         -- for *initial segment of* input list
-                                         --   (but reversed; doesn't matter)
-                                         -- VoidRep args do not appear here
-                     [(CgRep,a)])        -- Leftover arg or result values
-
-assignCallRegs       :: DynFlags -> AssignRegs a
-assignPrimOpCallRegs :: DynFlags -> AssignRegs a
-assignReturnRegs     :: DynFlags -> AssignRegs a
-
-assignCallRegs dflags args
-  = assign_regs args (mkRegTbl dflags [node])
-        -- The entry convention for a function closure
-        -- never uses Node for argument passing; instead
-        -- Node points to the function closure itself
-
-assignPrimOpCallRegs dflags args
- = assign_regs args (mkRegTbl_allRegs dflags [])
-        -- For primops, *all* arguments must be passed in registers
-
-assignReturnRegs dflags args
- -- when we have a single non-void component to return, use the normal
- -- unpointed return convention.  This make various things simpler: it
- -- means we can assume a consistent convention for IO, which is useful
- -- when writing code that relies on knowing the IO return convention in
- -- the RTS (primops, especially exception-related primops).
- -- Also, the bytecode compiler assumes this when compiling
- -- case expressions and ccalls, so it only needs to know one set of
- -- return conventions.
- | [(rep,arg)] <- non_void_args, CmmGlobal r <- dataReturnConvPrim rep
-    = ([(arg, r)], [])
- | otherwise
-    = assign_regs args (mkRegTbl dflags [])
-        -- For returning unboxed tuples etc,
-        -- we use all regs
- where
-       non_void_args = filter ((/= VoidArg).fst) args
-
-assign_regs :: [(CgRep,a)]      -- Arg or result values to assign
-            -> AvailRegs        -- Regs still avail: Vanilla, Float, Double, Longs
-            -> ([(a, GlobalReg)], [(CgRep, a)])
-assign_regs args supply
-  = go args [] supply
-  where
-    go [] acc _ = (acc, [])     -- Return the results reversed (doesn't matter)
-    go ((VoidArg,_) : args) acc supply  -- Skip void arguments; they aren't passed, and
-        = go args acc supply            -- there's nothing to bind them to
-    go ((rep,arg) : args) acc supply
-        = case assign_reg rep supply of
-                Just (reg, supply') -> go args ((arg,reg):acc) supply'
-                Nothing             -> (acc, (rep,arg):args)    -- No more regs
-
-assign_reg :: CgRep -> AvailRegs -> Maybe (GlobalReg, AvailRegs)
-assign_reg FloatArg  (vs, f:fs, ds, ls) = Just (FloatReg f,   (vs, fs, ds, ls))
-assign_reg DoubleArg (vs, fs, d:ds, ls) = Just (DoubleReg d,  (vs, fs, ds, ls))
-assign_reg LongArg   (vs, fs, ds, l:ls) = Just (LongReg l,    (vs, fs, ds, ls))
-assign_reg PtrArg    (v:vs, fs, ds, ls) = Just (VanillaReg v VGcPtr, (vs, fs, ds, ls))
-assign_reg NonPtrArg (v:vs, fs, ds, ls) = Just (VanillaReg v VNonGcPtr, (vs, fs, ds, ls))
-    -- PtrArg and NonPtrArg both go in a vanilla register
-assign_reg _         _                  = Nothing
-
-
--------------------------------------------------------------------------
---
---              Register supplies
---
--------------------------------------------------------------------------
-
--- Vanilla registers can contain pointers, Ints, Chars.
--- Floats and doubles have separate register supplies.
---
--- We take these register supplies from the *real* registers, i.e. those
--- that are guaranteed to map to machine registers.
-
-useVanillaRegs :: DynFlags -> Int
-useVanillaRegs dflags
- | platformUnregisterised (targetPlatform dflags) = 0
- | otherwise                                      = mAX_Real_Vanilla_REG dflags
-useFloatRegs :: DynFlags -> Int
-useFloatRegs dflags
- | platformUnregisterised (targetPlatform dflags) = 0
- | otherwise                                      = mAX_Real_Float_REG dflags
-useDoubleRegs :: DynFlags -> Int
-useDoubleRegs dflags
- | platformUnregisterised (targetPlatform dflags) = 0
- | otherwise                                      = mAX_Real_Double_REG dflags
-useLongRegs :: DynFlags -> Int
-useLongRegs dflags
- | platformUnregisterised (targetPlatform dflags) = 0
- | otherwise                                      = mAX_Real_Long_REG dflags
-
-vanillaRegNos, floatRegNos, doubleRegNos, longRegNos :: DynFlags -> [Int]
-vanillaRegNos dflags = regList $ useVanillaRegs dflags
-floatRegNos   dflags = regList $ useFloatRegs   dflags
-doubleRegNos  dflags = regList $ useDoubleRegs  dflags
-longRegNos    dflags = regList $ useLongRegs    dflags
-
-allVanillaRegNos, allFloatRegNos, allDoubleRegNos, allLongRegNos
-    :: DynFlags -> [Int]
-allVanillaRegNos dflags = regList $ mAX_Vanilla_REG dflags
-allFloatRegNos   dflags = regList $ mAX_Float_REG   dflags
-allDoubleRegNos  dflags = regList $ mAX_Double_REG  dflags
-allLongRegNos    dflags = regList $ mAX_Long_REG    dflags
-
-regList :: Int -> [Int]
-regList n = [1 .. n]
-
-type AvailRegs = ( [Int]   -- available vanilla regs.
-                 , [Int]   -- floats
-                 , [Int]   -- doubles
-                 , [Int]   -- longs (int64 and word64)
-                 )
-
-mkRegTbl :: DynFlags -> [GlobalReg] -> AvailRegs
-mkRegTbl dflags regs_in_use
-  = mkRegTbl' dflags regs_in_use
-              vanillaRegNos floatRegNos doubleRegNos longRegNos
-
-mkRegTbl_allRegs :: DynFlags -> [GlobalReg] -> AvailRegs
-mkRegTbl_allRegs dflags regs_in_use
-  = mkRegTbl' dflags regs_in_use
-              allVanillaRegNos allFloatRegNos allDoubleRegNos allLongRegNos
-
-mkRegTbl' :: DynFlags -> [GlobalReg]
-          -> (DynFlags -> [Int])
-          -> (DynFlags -> [Int])
-          -> (DynFlags -> [Int])
-          -> (DynFlags -> [Int])
-          -> ([Int], [Int], [Int], [Int])
-mkRegTbl' dflags regs_in_use vanillas floats doubles longs
-  = (ok_vanilla, ok_float, ok_double, ok_long)
-  where
-    ok_vanilla = mapCatMaybes (select (\i -> VanillaReg i VNonGcPtr))
-                              (vanillas dflags)
-                    -- ptrhood isn't looked at, hence we can use any old rep.
-    ok_float   = mapCatMaybes (select FloatReg)  (floats  dflags)
-    ok_double  = mapCatMaybes (select DoubleReg) (doubles dflags)
-    ok_long    = mapCatMaybes (select LongReg)   (longs   dflags)
-
-    select :: (Int -> GlobalReg) -> Int{-cand-} -> Maybe Int
-        -- one we've unboxed the Int, we make a GlobalReg
-        -- and see if it is already in use; if not, return its number.
-
-    select mk_reg_fun cand
-      = let
-            reg = mk_reg_fun cand
-        in
-        if reg `not_elem` regs_in_use
-        then Just cand
-        else Nothing
-      where
-        not_elem = isn'tIn "mkRegTbl"
-
-