From 98eae0160d08e378f9e256f7564ce21dd0016a65 Mon Sep 17 00:00:00 2001 From: simonmar Date: Thu, 21 Nov 2002 10:04:21 +0000 Subject: [PATCH] [project @ 2002-11-21 10:04:20 by simonmar] Repair the HEAD after some file adds/removes that were supposed to happen on the eval-apply-branch yesterday mysteriously happened on the HEAD instead. --- ghc/compiler/nativeGen/StixInfo.lhs | 168 +++++++++++ ghc/rts/LinkerBasic.c | 64 ++++ ghc/utils/genapply/GenApply.hs | 555 ----------------------------------- ghc/utils/genapply/Makefile | 13 - 4 files changed, 232 insertions(+), 568 deletions(-) create mode 100644 ghc/compiler/nativeGen/StixInfo.lhs create mode 100644 ghc/rts/LinkerBasic.c delete mode 100644 ghc/utils/genapply/GenApply.hs delete mode 100644 ghc/utils/genapply/Makefile diff --git a/ghc/compiler/nativeGen/StixInfo.lhs b/ghc/compiler/nativeGen/StixInfo.lhs new file mode 100644 index 0000000..7dcae06 --- /dev/null +++ b/ghc/compiler/nativeGen/StixInfo.lhs @@ -0,0 +1,168 @@ +% +% (c) The AQUA Project, Glasgow University, 1993-1998 +% + +\begin{code} +module StixInfo ( + + genCodeInfoTable, genBitmapInfoTable, + + bitmapToIntegers, bitmapIsSmall, livenessIsSmall + + ) where + +#include "HsVersions.h" +#include "../includes/config.h" +#include "NCG.h" + +import AbsCSyn ( AbstractC(..), Liveness(..), C_SRT(..), needsSRT ) +import ClosureInfo ( closurePtrsSize, + closureNonHdrSize, closureSMRep, + infoTableLabelFromCI, + closureSRT, closureSemiTag + ) +import PrimRep ( PrimRep(..) ) +import SMRep ( getSMRepClosureTypeInt ) +import Stix -- all of it +import UniqSupply ( returnUs, UniqSM ) +import BitSet ( BitSet, intBS ) +import Maybes ( maybeToBool ) + +import DATA_BITS +import DATA_WORD +\end{code} + +Generating code for info tables (arrays of data). + +\begin{code} +genCodeInfoTable + :: AbstractC + -> UniqSM StixStmtList + +genCodeInfoTable (CClosureInfoAndCode cl_info _ _ cl_descr) + = returnUs (\xs -> StData PtrRep table : StLabel info_lbl : xs) + + where + info_lbl = infoTableLabelFromCI cl_info + + table | needs_srt = srt_label : rest_of_table + | otherwise = rest_of_table + + rest_of_table = + [ + {- par, prof, debug -} + StInt (toInteger layout_info) + , StInt (toInteger type_info) + ] + + -- sigh: building up the info table is endian-dependent. + -- ToDo: do this using .byte and .word directives. + type_info :: Word32 +#ifdef WORDS_BIGENDIAN + type_info = (fromIntegral closure_type `shiftL` 16) .|. + (fromIntegral srt_len) +#else + type_info = (fromIntegral closure_type) .|. + (fromIntegral srt_len `shiftL` 16) +#endif + srt = closureSRT cl_info + needs_srt = needsSRT srt + + (srt_label,srt_len) + | is_constr + = (StInt 0, tag) + | otherwise + = case srt of + NoC_SRT -> (StInt 0, 0) + C_SRT lbl off len -> (StIndex DataPtrRep (StCLbl lbl) (StInt (toInteger off)), len) + + maybe_tag = closureSemiTag cl_info + is_constr = maybeToBool maybe_tag + (Just tag) = maybe_tag + + layout_info :: Word32 +#ifdef WORDS_BIGENDIAN + layout_info = (fromIntegral ptrs `shiftL` 16) .|. fromIntegral nptrs +#else + layout_info = (fromIntegral ptrs) .|. (fromIntegral nptrs `shiftL` 16) +#endif + + ptrs = closurePtrsSize cl_info + nptrs = size - ptrs + + size = closureNonHdrSize cl_info + + closure_type = getSMRepClosureTypeInt (closureSMRep cl_info) + + + +genBitmapInfoTable + :: Liveness + -> C_SRT + -> Int + -> Bool -- must include SRT field (i.e. it's a vector) + -> UniqSM StixStmtList + +genBitmapInfoTable liveness srt closure_type include_srt + = returnUs (\xs -> StData PtrRep table : xs) + + where + table = if srt_len == 0 && not include_srt then + rest_of_table + else + srt_label : rest_of_table + + rest_of_table = + [ + {- par, prof, debug -} + layout_info + , StInt (toInteger type_info) + ] + + layout_info = case liveness of + Liveness lbl mask -> + case bitmapToIntegers mask of + [ ] -> StInt 0 + [i] -> StInt i + _ -> StCLbl lbl + + type_info :: Word32 +#ifdef WORDS_BIGENDIAN + type_info = (fromIntegral closure_type `shiftL` 16) .|. + (fromIntegral srt_len) +#else + type_info = (fromIntegral closure_type) .|. + (fromIntegral srt_len `shiftL` 16) +#endif + + (srt_label,srt_len) = + case srt of + NoC_SRT -> (StInt 0, 0) + C_SRT lbl off len -> + (StIndex DataPtrRep (StCLbl lbl) + (StInt (toInteger off)), len) + +bitmapToIntegers :: [BitSet] -> [Integer] +bitmapToIntegers = bundle . map (toInteger . intBS) + where +#if BYTES_PER_WORD == 4 + bundle = id +#else + bundle [] = [] + bundle is = case splitAt (BYTES_PER_WORD/4) is of + (these, those) -> + ( foldr1 (\x y -> x + 4294967296 * y) + [x `mod` 4294967296 | x <- these] + : bundle those + ) +#endif + +bitmapIsSmall :: [BitSet] -> Bool +bitmapIsSmall bitmap + = case bitmapToIntegers bitmap of + _:_:_ -> False + _ -> True + +livenessIsSmall :: Liveness -> Bool +livenessIsSmall (Liveness _ mask) = bitmapIsSmall mask +\end{code} diff --git a/ghc/rts/LinkerBasic.c b/ghc/rts/LinkerBasic.c new file mode 100644 index 0000000..2d3e603 --- /dev/null +++ b/ghc/rts/LinkerBasic.c @@ -0,0 +1,64 @@ +/* ----------------------------------------------------------------------------- + * $Id: LinkerBasic.c,v 1.6 2002/11/21 10:04:21 simonmar Exp $ + * + * (c) The GHC Team, 2000 + * + * RTS Object Linker + * + * ---------------------------------------------------------------------------*/ + +#include "PosixSource.h" +#include "Rts.h" +#include "Hash.h" +#include "StoragePriv.h" +#include "LinkerInternals.h" + +/* List of currently loaded objects */ +ObjectCode *objects = NULL; /* initially empty */ + +/* ----------------------------------------------------------------------------- + * Look up an address to discover whether it is in text or data space. + * + * Used by the garbage collector when walking the stack. + * -------------------------------------------------------------------------- */ + +static __inline__ SectionKind +lookupSection ( void* addr ) +{ + Section* se; + ObjectCode* oc; + + for (oc=objects; oc; oc=oc->next) { + for (se=oc->sections; se; se=se->next) { + if (se->start <= addr && addr <= se->end) + return se->kind; + } + } + return SECTIONKIND_OTHER; +} + +int +is_dynamically_loaded_code_or_rodata_ptr ( void* p ) +{ + SectionKind sk = lookupSection(p); + ASSERT (sk != SECTIONKIND_NOINFOAVAIL); + return (sk == SECTIONKIND_CODE_OR_RODATA); +} + + +int +is_dynamically_loaded_rwdata_ptr ( void* p ) +{ + SectionKind sk = lookupSection(p); + ASSERT (sk != SECTIONKIND_NOINFOAVAIL); + return (sk == SECTIONKIND_RWDATA); +} + + +int +is_not_dynamically_loaded_ptr ( void* p ) +{ + SectionKind sk = lookupSection(p); + ASSERT (sk != SECTIONKIND_NOINFOAVAIL); + return (sk == SECTIONKIND_OTHER); +} diff --git a/ghc/utils/genapply/GenApply.hs b/ghc/utils/genapply/GenApply.hs deleted file mode 100644 index b612a0b..0000000 --- a/ghc/utils/genapply/GenApply.hs +++ /dev/null @@ -1,555 +0,0 @@ -{-# OPTIONS -cpp #-} -module Main(main) where - -#include "config.h" -#include "MachRegs.h" - -#if __GLASGOW_HASKELL__ >= 504 -import Text.PrettyPrint -import Data.Word -import Data.Bits -import Data.List ( intersperse ) -import Data.Char ( toUpper ) -#else -import Bits -import Word -import Pretty -import List ( intersperse ) -import Char ( toUpper ) -#endif - - --- ----------------------------------------------------------------------------- --- Argument kinds (rougly equivalent to PrimRep) - -data ArgRep - = N -- non-ptr - | P -- ptr - | V -- void - | F -- float - | D -- double - | L -- long (64-bit) - --- size of a value in *words* -argSize :: ArgRep -> Int -argSize N = 1 -argSize P = 1 -argSize V = 0 -argSize F = 1 -argSize D = (SIZEOF_DOUBLE `quot` SIZEOF_VOID_P :: Int) -argSize L = (8 `quot` SIZEOF_VOID_P :: Int) - -showArg :: ArgRep -> Char -showArg N = 'n' -showArg P = 'p' -showArg V = 'v' -showArg F = 'f' -showArg D = 'd' -showArg L = 'l' - --- is a value a pointer? -isPtr :: ArgRep -> Bool -isPtr P = True -isPtr _ = False - --- ----------------------------------------------------------------------------- --- Registers - -type Reg = String - -availableRegs :: ([Reg],[Reg],[Reg],[Reg]) -availableRegs = - ( vanillaRegs MAX_REAL_VANILLA_REG, - floatRegs MAX_REAL_FLOAT_REG, - doubleRegs MAX_REAL_DOUBLE_REG, - longRegs MAX_REAL_LONG_REG - ) - -vanillaRegs, floatRegs, doubleRegs, longRegs :: Int -> [Reg] -vanillaRegs n = [ "R" ++ show m ++ ".w" | m <- [2..n] ] -- never use R1 -floatRegs n = [ "F" ++ show m | m <- [1..n] ] -doubleRegs n = [ "D" ++ show m | m <- [1..n] ] -longRegs n = [ "L" ++ show m | m <- [1..n] ] - --- ----------------------------------------------------------------------------- --- Loading/saving register arguments to the stack - -loadRegArgs :: Int -> [ArgRep] -> (Doc,Int) -loadRegArgs sp args = (vcat (map (uncurry assign_stk_to_reg) reg_locs), sp') - where - (reg_locs, sp') = assignRegs sp args - --- a bit like assignRegs in CgRetConv.lhs -assignRegs - :: Int -- Sp of first arg - -> [ArgRep] -- args - -> ([(Reg,Int)], Int) -- Sp and rest of args -assignRegs sp args = assign sp args availableRegs [] - -assign sp [] regs doc = (doc, sp) -assign sp (V : args) regs doc = assign sp args regs doc -assign sp (arg : args) regs doc - = case findAvailableReg arg regs of - Just (reg, regs') -> assign (sp + argSize arg) args regs' - ((reg, sp) : doc) - Nothing -> (doc, sp) - -findAvailableReg N (vreg:vregs, fregs, dregs, lregs) = - Just (vreg, (vregs,fregs,dregs,lregs)) -findAvailableReg P (vreg:vregs, fregs, dregs, lregs) = - Just (vreg, (vregs,fregs,dregs,lregs)) -findAvailableReg F (vregs, freg:fregs, dregs, lregs) = - Just (freg, (vregs,fregs,dregs,lregs)) -findAvailableReg D (vregs, fregs, dreg:dregs, lregs) = - Just (dreg, (vregs,fregs,dregs,lregs)) -findAvailableReg L (vregs, fregs, dregs, lreg:lregs) = - Just (lreg, (vregs,fregs,dregs,lregs)) -findAvailableReg _ _ = Nothing - -assign_reg_to_stk reg@('F':_) sp - = text "ASSIGN_FLT(Sp+" <> int sp <> comma <> text reg <> text ");" -assign_reg_to_stk reg@('D':_) sp - = text "ASSIGN_DBL(Sp+" <> int sp <> comma <> text reg <> text ");" -assign_reg_to_stk reg@('L':_) sp - = text "ASSIGN_Word64(Sp+" <> int sp <> comma <> text reg <> text ");" -assign_reg_to_stk reg sp - = text "Sp[" <> int sp <> text "] = " <> text reg <> semi - -assign_stk_to_reg reg@('F':_) sp - = text reg <> text " = " <> text "PK_FLT(Sp+" <> int sp <> text ");" -assign_stk_to_reg reg@('D':_) sp - = text reg <> text " = " <> text "PK_DBL(Sp+" <> int sp <> text ");" -assign_stk_to_reg reg@('L':_) sp - = text reg <> text " = " <> text "PK_Word64(Sp+" <> int sp <> text ");" -assign_stk_to_reg reg sp - = text reg <> text " = Sp[" <> int sp <> text "];" - - --- make a ptr/non-ptr bitmap from a list of argument types -mkBitmap :: [ArgRep] -> Word32 -mkBitmap args = foldr f 0 args - where f arg bm | isPtr arg = bm `shiftL` 1 - | otherwise = (bm `shiftL` size) .|. ((1 `shiftL` size) - 1) - where size = argSize arg - --- ----------------------------------------------------------------------------- --- Generating the application functions - -mkApplyRetName args - = text "stg_ap_" <> text (map showArg args) <> text "_ret" - -mkApplyInfoName args - = text "stg_ap_" <> text (map showArg args) <> text "_info" - -genMkPAP macro jump is_pap args all_args_size fun_info_label - = smaller_arity_cases - $$ exact_arity_case - $$ larger_arity_case - - where - n_args = length args - --- The SMALLER ARITY cases: --- if (arity == 1) { --- Sp[0] = Sp[1]; --- Sp[1] = (W_)&stg_ap_1_info; --- JMP_(GET_ENTRY(R1.cl)); - - smaller_arity_cases = vcat [ smaller_arity i | i <- [1..n_args-1] ] - - smaller_arity arity - = text "if (arity == " <> int arity <> text ") {" $$ - let - (reg_doc, sp') - | is_pap = (empty, 1) - | otherwise = loadRegArgs 1 these_args - in - nest 4 (vcat [ - reg_doc, - vcat [ shuffle_down j | j <- [sp'..these_args_size] ], - text "Sp[" <> int these_args_size <> text "] = (W_)&" <> - mkApplyInfoName rest_args <> semi, - text "Sp += " <> int (sp' - 1) <> semi, - -- for a PAP, we have to arrange that the stack contains a - -- return address in the even that stg_PAP_entry fails its - -- heap check. See stg_PAP_entry in Apply.hc for details. - if is_pap - then text "Sp--; Sp[0] = (W_)&" <> mkApplyInfoName these_args <> semi - else empty, - text "JMP_" <> parens (text jump) <> semi - ]) $$ - text "}" - where - (these_args, rest_args) = splitAt arity args - these_args_size = sum (map argSize these_args) - - shuffle_down i = - text "Sp[" <> int (i-1) <> text "] = Sp[" - <> int i <> text "];" - --- The EXACT ARITY case --- --- if (arity == 1) { --- Sp++; --- JMP_(GET_ENTRY(R1.cl)); - - exact_arity_case - = text "if (arity == " <> int n_args <> text ") {" $$ - let - (reg_doc, sp') - | is_pap = (empty, 0) - | otherwise = loadRegArgs 1 args - in - nest 4 (vcat [ - reg_doc, - text "Sp += " <> int sp' <> semi, - if is_pap - then text "Sp[0] = (W_)&" <> fun_info_label <> semi - else empty, - text "JMP_" <> parens (text jump) <> semi - ]) - --- The LARGER ARITY cases: --- --- } else /* arity > 1 */ { --- BUILD_PAP(1,0,(W_)&stg_ap_v_info); --- } - - larger_arity_case = - text "} else {" $$ - nest 4 ( - text macro <> char '(' <> int n_args <> comma <> - int all_args_size <> - text ",(W_)&" <> fun_info_label <> - text ");" - ) $$ - char '}' - --- ----------------------------------------------------------------------------- --- generate an apply function - --- args is a list of 'p', 'n', 'f', 'd' or 'l' - -genApply args = - let - fun_ret_label = mkApplyRetName args - fun_info_label = mkApplyInfoName args - all_args_size = sum (map argSize args) - in - vcat [ - text "INFO_TABLE_RET(" <> fun_info_label <> text "," <> - fun_ret_label <> text "," <> - text "MK_SMALL_BITMAP(" <> int all_args_size <> text "/*framsize*/," <> - int (fromIntegral (mkBitmap args)) <> text "/*bitmap*/), " <> - text "0,0,0,RET_SMALL,,EF_,0,0);", - text "", - text "F_ " <> fun_ret_label <> text "( void )\n{", - nest 4 (vcat [ - text "StgInfoTable *info;", - text "nat arity;", - --- if fast == 1: --- print "static void *lbls[] =" --- print " { [FUN] &&fun_lbl," --- print " [FUN_1_0] &&fun_lbl," --- print " [FUN_0_1] &&fun_lbl," --- print " [FUN_2_0] &&fun_lbl," --- print " [FUN_1_1] &&fun_lbl," --- print " [FUN_0_2] &&fun_lbl," --- print " [FUN_STATIC] &&fun_lbl," --- print " [PAP] &&pap_lbl," --- print " [THUNK] &&thunk_lbl," --- print " [THUNK_1_0] &&thunk_lbl," --- print " [THUNK_0_1] &&thunk_lbl," --- print " [THUNK_2_0] &&thunk_lbl," --- print " [THUNK_1_1] &&thunk_lbl," --- print " [THUNK_0_2] &&thunk_lbl," --- print " [THUNK_STATIC] &&thunk_lbl," --- print " [THUNK_SELECTOR] &&thunk_lbl," --- print " [IND] &&ind_lbl," --- print " [IND_OLDGEN] &&ind_lbl," --- print " [IND_STATIC] &&ind_lbl," --- print " [IND_PERM] &&ind_lbl," --- print " [IND_OLDGEN_PERM] &&ind_lbl" --- print " };" - - text "FB_", - text "", - text "IF_DEBUG(apply,fprintf(stderr, \"" <> fun_ret_label <> - text "... \"); printClosure(R1.cl));", - text "IF_DEBUG(sanity,checkStackChunk(Sp+" <> int (1 + all_args_size) <> - text ", CurrentTSO->stack + CurrentTSO->stack_size));", - - text "TICK_SLOW_CALL(" <> int (length args) <> text ");", - - let do_assert [] _ = [] - do_assert (arg:args) offset - | isPtr arg = this : rest - | otherwise = rest - where this = text "ASSERT(LOOKS_LIKE_CLOSURE_PTR(Sp[" - <> int offset <> text "]));" - rest = do_assert args (offset + argSize arg) - in - vcat (do_assert args 1), - - text "again:", - text "info = get_itbl(R1.cl);", - --- if fast == 1: --- print " goto *lbls[info->type];"; --- else: - text "switch (info->type) {" $$ - nest 4 (vcat [ - --- if fast == 1: --- print " fun_lbl:" --- else: - text "case FUN:", - text "case FUN_1_0:", - text "case FUN_0_1:", - text "case FUN_2_0:", - text "case FUN_1_1:", - text "case FUN_0_2:", - text "case FUN_STATIC:", - nest 4 (vcat [ - text "arity = itbl_to_fun_itbl(info)->arity;", - text "ASSERT(arity > 0);", - genMkPAP "BUILD_PAP" "GET_ENTRY(R1.cl)" False{-not PAP-} - args all_args_size fun_info_label - ]), - --- if fast == 1: --- print " pap_lbl:" --- else: - - text "case PAP:", - nest 4 (vcat [ - text "arity = ((StgPAP *)R1.p)->arity;", - text "ASSERT(arity > 0);", - genMkPAP "NEW_PAP" "stg_PAP_entry" True{-is PAP-} - args all_args_size fun_info_label - ]), - - text "", - --- if fast == 1: --- print " thunk_lbl:" --- else: - text "case THUNK:", - text "case THUNK_1_0:", - text "case THUNK_0_1:", - text "case THUNK_2_0:", - text "case THUNK_1_1:", - text "case THUNK_0_2:", - text "case THUNK_STATIC:", - text "case THUNK_SELECTOR:", - nest 4 (vcat [ - text "Sp[0] = (W_)&" <> fun_info_label <> text ";", - text "JMP_(GET_ENTRY(R1.cl));", - text "" - ]), - --- if fast == 1: --- print " ind_lbl:" --- else: - text "case IND:", - text "case IND_OLDGEN:", - text "case IND_STATIC:", - text "case IND_PERM:", - text "case IND_OLDGEN_PERM:", - nest 4 (vcat [ - text "R1.cl = ((StgInd *)R1.p)->indirectee;", - text "goto again;" - ]), - text "", - --- if fast == 0: - - text "default:", - nest 4 ( - text "barf(\"" <> fun_ret_label <> text "\");" - ), - text "}" - - ]) - ]), - text "FE_", - text "}" - ] - --- ----------------------------------------------------------------------------- --- Making a stack apply - --- These little functions are like slow entry points. They provide --- the layer between the PAP entry code and the function's fast entry --- point: namely they load arguments off the stack into registers (if --- available) and jump to the function's entry code. --- --- On entry: R1 points to the function closure --- arguments are on the stack starting at Sp --- --- Invariant: the list of arguments never contains void. Since we're only --- interested in loading arguments off the stack here, we can ignore --- void arguments. - -mkStackApplyEntryLabel:: [ArgRep] -> Doc -mkStackApplyEntryLabel args = text "stg_ap_stk_" <> text (map showArg args) - -genStackApply :: [ArgRep] -> Doc -genStackApply args = - let fn_entry_label = mkStackApplyEntryLabel args in - vcat [ - text "IFN_" <> parens fn_entry_label, - text "{", - nest 4 (text "FB_" $$ body $$ text "FE_"), - text "}" - ] - where - (assign_regs, sp') = loadRegArgs 0 args - body = vcat [assign_regs, - text "Sp += " <> int sp' <> semi, - text "JMP_(GET_ENTRY(R1.cl))" - ] - --- ----------------------------------------------------------------------------- --- Stack save entry points. --- --- These code fragments are used to save registers on the stack at a heap --- check failure in the entry code for a function. We also have to save R1 --- and the return address (stg_gen_ap_info) on the stack. See stg_fun_gc_gen --- in HeapStackCheck.hc for more details. - -mkStackSaveEntryLabel :: [ArgRep] -> Doc -mkStackSaveEntryLabel args = text "stg_stk_save_" <> text (map showArg args) - -genStackSave :: [ArgRep] -> Doc -genStackSave args = - let fn_entry_label= mkStackSaveEntryLabel args in - vcat [ - text "IFN_" <> parens fn_entry_label, - text "{", - nest 4 (text "FB_" $$ body $$ text "FE_"), - text "}" - ] - where - body = vcat [text "Sp -= " <> int sp_offset <> semi, - vcat (map (uncurry assign_reg_to_stk) reg_locs), - text "Sp[2] = R1.w;", - text "Sp[1] =" <+> int (sp_offset - std_frame_size) <> semi, - text "Sp[0] = (W_)&stg_gc_fun_info;", - text "JMP_(stg_gc_noregs);" - ] - - std_frame_size = 3 -- the std bits of the frame. See StgRetFun in Closures.h, - -- and the comment on stg_fun_gc_gen in HeapStackCheck.hc. - (reg_locs, sp_offset) = assignRegs std_frame_size args - --- ----------------------------------------------------------------------------- --- The prologue... - -main = putStr (render the_code) - where the_code = vcat [ - text "// DO NOT EDIT!", - text "// Automatically generated by GenApply.hs", - text "", - text "#include \"Stg.h\"", - text "#include \"Rts.h\"", - text "#include \"RtsFlags.h\"", - text "#include \"Storage.h\"", - text "#include \"RtsUtils.h\"", - text "#include \"Printer.h\"", - text "#include \"Sanity.h\"", - text "#include \"Apply.h\"", - text "", - text "#include ", - - vcat (intersperse (text "") $ map genApply applyTypes), - vcat (intersperse (text "") $ map genStackFns stackApplyTypes), - - genStackApplyArray stackApplyTypes, - genStackSaveArray stackApplyTypes, - genBitmapArray stackApplyTypes, - - text "" -- add a newline at the end of the file - ] - --- These have been shown to cover about 99% of cases in practice... -applyTypes = [ - [V], - [F], - [D], - [L], - [N], - [P], - [P,V], - [P,P], - [P,P,V], - [P,P,P], - [P,P,P,P], - [P,P,P,P,P], - [P,P,P,P,P,P], - [P,P,P,P,P,P,P] - ] - --- No need for V args in the stack apply cases. --- ToDo: the stack apply and stack save code doesn't make a distinction --- between N and P (they both live in the same register), only the bitmap --- changes, so we could share the apply/save code between lots of cases. -stackApplyTypes = [ - [N], - [P], - [F], - [D], - [L], - [N,N], - [N,P], - [P,N], - [P,P], - [N,N,N], - [N,N,P], - [N,P,N], - [N,P,P], - [P,N,N], - [P,N,P], - [P,P,N], - [P,P,P], - [P,P,P,P], - [P,P,P,P,P], - [P,P,P,P,P,P], - [P,P,P,P,P,P,P], - [P,P,P,P,P,P,P,P] - ] - -genStackFns args = genStackApply args $$ genStackSave args - - -genStackApplyArray types = - text "StgFun *stg_ap_stack_entries[] = {" $$ - vcat (map arr_ent types) $$ - text "};" - where - arr_ent ty = brackets (arg_const ty) <+> mkStackApplyEntryLabel ty <> comma - -genStackSaveArray types = - text "StgFun *stg_stack_save_entries[] = {" $$ - vcat (map arr_ent types) $$ - text "};" - where - arr_ent ty = brackets (arg_const ty) <+> mkStackSaveEntryLabel ty <> comma - -genBitmapArray :: [[ArgRep]] -> Doc -genBitmapArray types = - vcat [ - text "StgWord stg_arg_bitmaps[] = {", - vcat (map gen_bitmap types), - text "};" - ] - where - gen_bitmap ty = brackets (arg_const ty) <+> - text "MK_SMALL_BITMAP" <> parens ( - int (sum (map argSize ty)) <> comma <> - text (show (mkBitmap ty))) <> - comma - -arg_const ty = text "ARG_" <> text (map toUpper (map showArg ty)) - diff --git a/ghc/utils/genapply/Makefile b/ghc/utils/genapply/Makefile deleted file mode 100644 index c15b745..0000000 --- a/ghc/utils/genapply/Makefile +++ /dev/null @@ -1,13 +0,0 @@ -TOP=../.. -include $(TOP)/mk/boilerplate.mk - -HS_PROG = $(GHC_GENAPPLY_PGM) - -SRC_HC_OPTS += -I$(GHC_INCLUDE_DIR) - -# genapply is needed to boot in ghc/rts... -ifneq "$(BootingFromHc)" "YES" -boot :: all -endif - -include $(TOP)/mk/target.mk -- 1.7.10.4