Commit 6fbd46b0 authored by Simon Marlow's avatar Simon Marlow

Remove the old codegen

Except for CgUtils.fixStgRegisters that is used in the NCG and LLVM
backends, and should probably be moved somewhere else.
parent 53810006
......@@ -179,7 +179,7 @@ import StgCmmUtils
import StgCmmForeign
import StgCmmExpr
import StgCmmClosure
import StgCmmLayout
import StgCmmLayout hiding (ArgRep(..))
import StgCmmTicky
import StgCmmBind ( emitBlackHoleCode, emitUpdateFrame )
......
......@@ -24,7 +24,7 @@ module OldCmm (
module CmmExpr,
Section(..), ProfilingInfo(..), C_SRT(..)
Section(..), ProfilingInfo(..), New.C_SRT(..)
) where
#include "HsVersions.h"
......@@ -35,7 +35,6 @@ import Cmm ( CmmInfoTable(..), GenCmmGroup, CmmStatics(..), GenCmmDecl(..),
ProfilingInfo(..), ClosureTypeInfo(..) )
import BlockId
import ClosureInfo
import CmmExpr
import FastString
import ForeignCall
......@@ -184,7 +183,7 @@ type HintedCmmActual = CmmHinted CmmActual
data CmmSafety
= CmmUnsafe
| CmmSafe C_SRT
| CmmSafe New.C_SRT
| CmmInterruptible
-- | enable us to fold used registers over '[CmmActual]' and '[CmmFormal]'
......
......@@ -5,9 +5,6 @@
Storage manager representation of closures
This is here, rather than in ClosureInfo, just to keep nhc happy.
Other modules should access this info through ClosureInfo.
\begin{code}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
......
This diff is collapsed.
\begin{code}
module CgBindery where
import VarEnv( IdEnv )
data CgIdInfo
data VolatileLoc
data StableLoc
type CgBindings = IdEnv CgIdInfo
nukeVolatileBinds :: CgBindings -> CgBindings
\end{code}
\ No newline at end of file
-----------------------------------------------------------------------------
--
-- (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"
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
%
% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\begin{code}
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details
module CgExpr ( cgExpr ) where
#include "HsVersions.h"
import StgSyn
import CgMonad
import CostCentre
import SMRep
import CoreSyn
import CgProf
import CgHeapery
import CgBindery
import CgCase
import CgClosure
import CgCon
import CgLetNoEscape
import CgTailCall
import CgInfoTbls
import CgForeignCall
import CgPrimOp
import CgHpc
import CgUtils
import ClosureInfo
import OldCmm
import OldCmmUtils
import VarSet
import Literal
import PrimOp
import Id
import TyCon
import Type
import Maybes
import ListSetOps
import BasicTypes
import Util
import DynFlags
import Outputable
\end{code}
This module provides the support code for @StgToAbstractC@ to deal
with STG {\em expressions}. See also @CgClosure@, which deals
with closures, and @CgCon@, which deals with constructors.
\begin{code}
cgExpr :: StgExpr -- input
-> Code -- output
\end{code}
%********************************************************
%* *
%* Tail calls *
%* *
%********************************************************
``Applications'' mean {\em tail calls}, a service provided by module
@CgTailCall@. This includes literals, which show up as
@(STGApp (StgLitArg 42) [])@.
\begin{code}
cgExpr (StgApp fun args) = cgTailCall fun args
\end{code}
%********************************************************
%* *
%* STG ConApps (for inline versions) *
%* *
%********************************************************
\begin{code}
cgExpr (StgConApp con args)
= do { amodes <- getArgAmodes args
; cgReturnDataCon con amodes }
\end{code}
Literals are similar to constructors; they return by putting
themselves in an appropriate register and returning to the address on
top of the stack.
\begin{code}
cgExpr (StgLit lit)
= do { cmm_lit <- cgLit lit
; performPrimReturn rep (CmmLit cmm_lit) }
where
rep = (typeCgRep) (literalType lit)
\end{code}
%********************************************************
%* *
%* PrimOps and foreign calls.
%* *
%********************************************************
NOTE about "safe" foreign calls: a safe foreign call is never compiled
inline in a case expression. When we see
case (ccall ...) of { ... }
We generate a proper return address for the alternatives and push the
stack frame before doing the call, so that in the event that the call
re-enters the RTS the stack is in a sane state.
\begin{code}
cgExpr (StgOpApp (StgFCallOp fcall _) stg_args res_ty) = do
dflags <- getDynFlags
{-
First, copy the args into temporaries. We're going to push
a return address right before doing the call, so the args
must be out of the way.
-}
reps_n_amodes <- getArgAmodes stg_args
let
-- Get the *non-void* args, and jiggle them with shimForeignCall
arg_exprs = [ (shimForeignCallArg dflags stg_arg expr, stg_arg)
| (stg_arg, (rep,expr)) <- stg_args `zip` reps_n_amodes,
nonVoidArg rep]
arg_tmps <- sequence [ assignTemp arg
| (arg, _) <- arg_exprs]
let arg_hints = zipWith CmmHinted arg_tmps (map (typeForeignHint.stgArgType) stg_args)
{-
Now, allocate some result regs.
-}
(res_reps,res_regs,res_hints) <- newUnboxedTupleRegs res_ty
ccallReturnUnboxedTuple (zip res_reps (map (CmmReg . CmmLocal) res_regs)) $
emitForeignCall (zipWith CmmHinted res_regs res_hints) fcall
arg_hints emptyVarSet{-no live vars-}
-- tagToEnum# is special: we need to pull the constructor out of the table,
-- and perform an appropriate return.
cgExpr (StgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty)
= ASSERT(isEnumerationTyCon tycon)
do { dflags <- getDynFlags
; (_rep,amode) <- getArgAmode arg