From 491f66f835964bbcfa8f7acf46bc2bd1443be679 Mon Sep 17 00:00:00 2001 From: simonmar Date: Wed, 20 Nov 2002 14:10:04 +0000 Subject: [PATCH] [project @ 2002-11-20 14:09:42 by simonmar] Snapshot of the Eval/Apply changes, c. 15 Nov 2002. This snapshot should be relatively stable, although GHCi and profiling are currently known to be broken. --- ghc/compiler/nativeGen/StixInfo.lhs | 168 ----------- ghc/includes/StgFun.h | 46 +++ ghc/rts/Apply.h | 72 +++++ ghc/rts/Apply.hc | 131 +++++++++ ghc/rts/LinkerBasic.c | 64 ---- ghc/rts/Rts.h | 112 +++++++ ghc/utils/genapply/GenApply.hs | 555 +++++++++++++++++++++++++++++++++++ ghc/utils/genapply/Makefile | 13 + 8 files changed, 929 insertions(+), 232 deletions(-) delete mode 100644 ghc/compiler/nativeGen/StixInfo.lhs create mode 100644 ghc/includes/StgFun.h create mode 100644 ghc/rts/Apply.h create mode 100644 ghc/rts/Apply.hc delete mode 100644 ghc/rts/LinkerBasic.c create mode 100644 ghc/rts/Rts.h create mode 100644 ghc/utils/genapply/GenApply.hs create mode 100644 ghc/utils/genapply/Makefile diff --git a/ghc/compiler/nativeGen/StixInfo.lhs b/ghc/compiler/nativeGen/StixInfo.lhs deleted file mode 100644 index 7dcae06..0000000 --- a/ghc/compiler/nativeGen/StixInfo.lhs +++ /dev/null @@ -1,168 +0,0 @@ -% -% (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/includes/StgFun.h b/ghc/includes/StgFun.h new file mode 100644 index 0000000..32d955e --- /dev/null +++ b/ghc/includes/StgFun.h @@ -0,0 +1,46 @@ +/* ----------------------------------------------------------------------------- + * (c) The GHC Team, 2002 + * + * Things for functions. + * ---------------------------------------------------------------------------*/ + +#ifndef STGFUN_H +#define STGFUN_H + +/* generic - function comes with a small bitmap */ +#define ARG_GEN 0 + +/* generic - function comes with a large bitmap */ +#define ARG_GEN_BIG 1 + +/* specialised function types: bitmaps and calling sequences + * for these functions are pre-generated (see ghc/utils/genapply), and + * the generated code in ghc/rts/AutoApply.hc. + */ +#define ARG_N 2 +#define ARG_P 3 +#define ARG_F 4 +#define ARG_D 5 +#define ARG_L 6 +#define ARG_NN 7 +#define ARG_NP 8 +#define ARG_PN 9 +#define ARG_PP 10 +#define ARG_FF 11 +#define ARG_DD 12 +#define ARG_LL 13 +#define ARG_NNN 14 +#define ARG_NNP 15 +#define ARG_NPN 16 +#define ARG_NPP 17 +#define ARG_PNN 18 +#define ARG_PNP 19 +#define ARG_PPN 20 +#define ARG_PPP 21 +#define ARG_PPPP 22 +#define ARG_PPPPP 23 +#define ARG_PPPPPP 24 +#define ARG_PPPPPPP 25 +#define ARG_PPPPPPPP 26 + +#endif // STGFUN_H diff --git a/ghc/rts/Apply.h b/ghc/rts/Apply.h new file mode 100644 index 0000000..fe41341 --- /dev/null +++ b/ghc/rts/Apply.h @@ -0,0 +1,72 @@ +// ----------------------------------------------------------------------------- +// Apply.h +// +// (c) The University of Glasgow 2002 +// +// Helper bits for the generic apply code (AutoApply.hc) +// ----------------------------------------------------------------------------- + +#ifndef APPLY_H +#define APPLY_H + +// Build a new PAP: function is in R1,p +// ret addr and m arguments taking up n words are on the stack. +#define BUILD_PAP(m,n,f) \ + { \ + StgPAP *pap; \ + nat size, i; \ + TICK_SLOW_CALL_BUILT_PAP(); \ + size = PAP_sizeW(n); \ + HP_CHK_NP(size, Sp[0] = f;); \ + TICK_ALLOC_PAP(n, 0); \ + pap = (StgPAP *) (Hp + 1 - size); \ + SET_HDR(pap, &stg_PAP_info, CCCS); \ + pap->arity = arity - m; \ + pap->fun = R1.cl; \ + pap->n_args = n; \ + for (i = 0; i < n; i++) { \ + pap->payload[i] = (StgClosure *)Sp[1+i]; \ + } \ + R1.p = (P_)pap; \ + Sp += 1 + n; \ + JMP_(ENTRY_CODE(Sp[0])); \ + } + +// Copy the old PAP, build a new one with the extra arg(s) +// ret addr and m arguments taking up n words are on the stack. +#define NEW_PAP(m,n,f) \ + { \ + StgPAP *pap, *new_pap; \ + nat size, i; \ + TICK_SLOW_CALL_NEW_PAP(); \ + pap = (StgPAP *)R1.p; \ + size = PAP_sizeW(pap->n_args + n); \ + HP_CHK_NP(size, Sp[0] = f;); \ + TICK_ALLOC_PAP(n, 0); \ + new_pap = (StgPAP *) (Hp + 1 - size); \ + SET_HDR(new_pap, &stg_PAP_info, CCCS); \ + new_pap->arity = arity - m; \ + new_pap->n_args = pap->n_args + n; \ + new_pap->fun = pap->fun; \ + for (i = 0; i < pap->n_args; i++) { \ + new_pap->payload[i] = pap->payload[i]; \ + } \ + for (i = 0; i < n; i++) { \ + new_pap->payload[pap->n_args+i] = (StgClosure *)Sp[1+i]; \ + } \ + R1.p = (P_)new_pap; \ + Sp += n+1; \ + JMP_(ENTRY_CODE(Sp[0])); \ + } + +// canned slow entry points, indexed by arg type (ARG_P, ARG_PP, etc.) +extern StgFun * stg_ap_stack_entries[]; + +// canned register save code for heap check failure in a function +extern StgFun * stg_stack_save_entries[]; + +// canned bitmap for each arg type +extern StgWord stg_arg_bitmaps[]; + +#endif // APPLY_H + diff --git a/ghc/rts/Apply.hc b/ghc/rts/Apply.hc new file mode 100644 index 0000000..39ca488 --- /dev/null +++ b/ghc/rts/Apply.hc @@ -0,0 +1,131 @@ +// ----------------------------------------------------------------------------- +// Apply.hc +// +// (c) The University of Glasgow 2002 +// +// Application-related bits. +// +// ----------------------------------------------------------------------------- + +#include "Stg.h" +#include "Rts.h" +#include "RtsFlags.h" +#include "Storage.h" +#include "RtsUtils.h" +#include "Printer.h" +#include "Sanity.h" +#include "Apply.h" + +#include + +// ---------------------------------------------------------------------------- +// Evaluate a closure and return it. +// +// stg_ap_0_info <--- Sp +// +// NOTE: this needs to be a polymorphic return point, because we can't +// be sure that the thing being evaluated is not a function. + +// These names are just to keep VEC_POLY_INFO_TABLE() happy - all the +// entry points in the polymorphic info table point to the same code. +#define stg_ap_0_0_ret stg_ap_0_ret +#define stg_ap_0_1_ret stg_ap_0_ret +#define stg_ap_0_2_ret stg_ap_0_ret +#define stg_ap_0_3_ret stg_ap_0_ret +#define stg_ap_0_4_ret stg_ap_0_ret +#define stg_ap_0_5_ret stg_ap_0_ret +#define stg_ap_0_6_ret stg_ap_0_ret +#define stg_ap_0_7_ret stg_ap_0_ret + +VEC_POLY_INFO_TABLE(stg_ap_0, + MK_SMALL_BITMAP(0/*framsize*/, 0/*bitmap*/), + 0,0,0,RET_SMALL,,EF_); +F_ +stg_ap_0_ret(void) +{ + // fn is in R1, no args on the stack + StgInfoTable *info; + nat arity; + FB_; + + IF_DEBUG(apply,fprintf(stderr, "stg_ap_0_ret... "); printClosure(R1.cl)); + IF_DEBUG(sanity,checkStackChunk(Sp+1,CurrentTSO->stack + CurrentTSO->stack_size)); + + Sp++; + ENTER(); + FE_ +} + +/* ----------------------------------------------------------------------------- + Entry Code for a PAP. + + This entry code is *only* called by one of the stg_ap functions. + On entry: Sp points to the remaining arguments on the stack. If + the stack check fails, we can just push the PAP on the stack and + return to the scheduler. + + On entry: R1 points to the PAP. The rest of the function's arguments + (*all* of 'em) are on the stack, starting at Sp[0]. + + The idea is to copy the chunk of stack from the PAP object onto the + stack / into registers, and enter the function. + -------------------------------------------------------------------------- */ + +INFO_TABLE(stg_PAP_info,stg_PAP_entry,/*special layout*/0,0,PAP,,EF_,"PAP","PAP"); +STGFUN(stg_PAP_entry) +{ + nat Words; + StgPtr p; + nat i; + StgPAP *pap; + FB_ + + pap = (StgPAP *) R1.p; + + Words = pap->n_args; + + // Check for stack overflow and bump the stack pointer. + // We have a hand-rolled stack check fragment here, because none of + // the canned ones suit this situation. + if ((Sp - Words) < SpLim) { + DEBUG_ONLY(fprintf(stderr,"PAP STACK CHECK!\n")); + // there is a return address on the stack in the event of a + // stack check failure. The various stg_apply functions arrange + // this before calling stg_PAP_entry. + JMP_(stg_gc_unpt_r1); + } + // Sp is already pointing one word below the arguments... + Sp -= Words-1; + + // profiling + TICK_ENT_PAP(pap); + LDV_ENTER(pap); + // Enter PAP cost centre -- lexical scoping only + ENTER_CCS_PAP_CL(pap); + + R1.cl = pap->fun; + p = (P_)(pap->payload); + + // Reload the stack + for (i=0; ifun_type == ARG_GEN || info->fun_type == ARG_GEN_BIG) { + JMP_(info->slow_apply); + } else { + JMP_(stg_ap_stack_entries[info->fun_type]); + } + } +#endif + FE_ +} diff --git a/ghc/rts/LinkerBasic.c b/ghc/rts/LinkerBasic.c deleted file mode 100644 index 1c5c40b..0000000 --- a/ghc/rts/LinkerBasic.c +++ /dev/null @@ -1,64 +0,0 @@ -/* ----------------------------------------------------------------------------- - * $Id: LinkerBasic.c,v 1.4 2001/09/04 16:33:04 sewardj 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/rts/Rts.h b/ghc/rts/Rts.h new file mode 100644 index 0000000..e209a45 --- /dev/null +++ b/ghc/rts/Rts.h @@ -0,0 +1,112 @@ +/* ----------------------------------------------------------------------------- + * $Id$ + * + * (c) The GHC Team, 1998-1999 + * + * Top-level include file for the RTS itself + * + * ---------------------------------------------------------------------------*/ + +#ifndef RTS_H +#define RTS_H + +#ifdef __cplusplus +extern "C" { +#endif + +#ifndef IN_STG_CODE +#define IN_STG_CODE 0 +#endif +#include "Stg.h" + +/* ----------------------------------------------------------------------------- + RTS Exit codes + -------------------------------------------------------------------------- */ + +/* 255 is allegedly used by dynamic linkers to report linking failure */ +#define EXIT_INTERNAL_ERROR 254 +#define EXIT_DEADLOCK 253 +#define EXIT_INTERRUPTED 252 +#define EXIT_HEAPOVERFLOW 251 +#define EXIT_KILLED 250 + +/* ----------------------------------------------------------------------------- + Miscellaneous garbage + -------------------------------------------------------------------------- */ + +/* declarations for runtime flags/values */ +#define MAX_RTS_ARGS 32 + +#ifdef _WIN32 +/* On the yucky side..suppress -Wmissing-declarations warnings when + * including + */ +extern void* GetCurrentFiber ( void ); +extern void* GetFiberData ( void ); +#endif + +/* ----------------------------------------------------------------------------- + Assertions and Debuggery + -------------------------------------------------------------------------- */ + +#define IF_RTSFLAGS(c,s) if (RtsFlags.c) { s; } + +/* ----------------------------------------------------------------------------- + Assertions and Debuggery + -------------------------------------------------------------------------- */ + +#ifdef DEBUG +#define IF_DEBUG(c,s) if (RtsFlags.DebugFlags.c) { s; } +#else +#define IF_DEBUG(c,s) doNothing() +#endif + +#ifdef DEBUG +#define DEBUG_ONLY(s) s +#else +#define DEBUG_ONLY(s) doNothing() +#endif + +#if defined(GRAN) && defined(DEBUG) +#define IF_GRAN_DEBUG(c,s) if (RtsFlags.GranFlags.Debug.c) { s; } +#else +#define IF_GRAN_DEBUG(c,s) doNothing() +#endif + +#if defined(PAR) && defined(DEBUG) +#define IF_PAR_DEBUG(c,s) if (RtsFlags.ParFlags.Debug.c) { s; } +#else +#define IF_PAR_DEBUG(c,s) doNothing() +#endif + +/* ----------------------------------------------------------------------------- + Attributes + -------------------------------------------------------------------------- */ + +#ifdef __GNUC__ /* Avoid spurious warnings */ +#if __GNUC__ >= 2 && __GNUC_MINOR__ >= 7 +#define STG_NORETURN __attribute__ ((noreturn)) +#define STG_UNUSED __attribute__ ((unused)) +#else +#define STG_NORETURN +#define STG_UNUSED +#endif +#else +#define STG_NORETURN +#define STG_UNUSED +#endif + +/* ----------------------------------------------------------------------------- + Useful macros and inline functions + -------------------------------------------------------------------------- */ + +#define stg_min(a,b) ({typeof(a) _a = (a), _b = (b); _a <= _b ? _a : _b; }) +#define stg_max(a,b) ({typeof(a) _a = (a), _b = (b); _a <= _b ? _b : _a; }) + +/* -------------------------------------------------------------------------- */ + +#ifdef __cplusplus +} +#endif + +#endif /* RTS_H */ diff --git a/ghc/utils/genapply/GenApply.hs b/ghc/utils/genapply/GenApply.hs new file mode 100644 index 0000000..b612a0b --- /dev/null +++ b/ghc/utils/genapply/GenApply.hs @@ -0,0 +1,555 @@ +{-# 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 new file mode 100644 index 0000000..c15b745 --- /dev/null +++ b/ghc/utils/genapply/Makefile @@ -0,0 +1,13 @@ +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