From 423d477bfecd490de1449c59325c8776f91d7aac Mon Sep 17 00:00:00 2001 From: simonmar Date: Fri, 13 Aug 2004 13:11:23 +0000 Subject: [PATCH] [project @ 2004-08-13 13:04:50 by simonmar] Merge backend-hacking-branch onto HEAD. Yay! --- ghc/compiler/HsVersions.h | 6 +- ghc/compiler/Makefile | 9 +- ghc/compiler/NOTES | 44 +- ghc/compiler/absCSyn/AbsCSyn.lhs | 540 -- ghc/compiler/absCSyn/AbsCUtils.lhs | 1315 ----- ghc/compiler/absCSyn/CLabel.lhs | 596 --- ghc/compiler/absCSyn/CStrings.lhs | 55 - ghc/compiler/absCSyn/Costs.lhs | 421 -- ghc/compiler/absCSyn/MachOp.hs | 460 -- ghc/compiler/absCSyn/PprAbsC.lhs | 1804 ------- ghc/compiler/basicTypes/Id.lhs | 6 +- ghc/compiler/basicTypes/Literal.lhs | 113 +- ghc/compiler/basicTypes/Name.lhs | 4 +- ghc/compiler/basicTypes/Unique.lhs | 28 +- ghc/compiler/cmm/CLabel.hs | 671 +++ ghc/compiler/cmm/Cmm.hs | 305 ++ ghc/compiler/cmm/CmmLex.x | 309 ++ ghc/compiler/cmm/CmmLint.hs | 152 + ghc/compiler/cmm/CmmParse.y | 878 ++++ ghc/compiler/cmm/CmmUtils.hs | 169 + ghc/compiler/cmm/MachOp.hs | 632 +++ ghc/compiler/cmm/PprC.hs | 958 ++++ ghc/compiler/cmm/PprCmm.hs | 460 ++ ghc/compiler/codeGen/CgBindery.lhs | 512 +- ghc/compiler/codeGen/CgCallConv.hs | 507 ++ ghc/compiler/codeGen/CgCase.lhs | 740 ++- ghc/compiler/codeGen/CgClosure.lhs | 893 ++-- ghc/compiler/codeGen/CgCon.lhs | 427 +- ghc/compiler/codeGen/CgConTbls.lhs | 163 - ghc/compiler/codeGen/CgExpr.lhs | 285 +- ghc/compiler/codeGen/CgForeignCall.hs | 216 + ghc/compiler/codeGen/CgHeapery.lhs | 735 ++- ghc/compiler/codeGen/CgInfoTbls.hs | 538 ++ ghc/compiler/codeGen/CgLetNoEscape.lhs | 64 +- ghc/compiler/codeGen/CgMonad.lhs | 867 +-- ghc/compiler/codeGen/CgParallel.hs | 90 + ghc/compiler/codeGen/CgPrimOp.hs | 588 +++ ghc/compiler/codeGen/CgProf.hs | 474 ++ ghc/compiler/codeGen/CgRetConv.hi-boot | 7 - ghc/compiler/codeGen/CgRetConv.lhs | 246 - ghc/compiler/codeGen/CgStackery.lhs | 444 +- ghc/compiler/codeGen/CgTailCall.lhs | 674 +-- ghc/compiler/codeGen/CgTicky.hs | 370 ++ ghc/compiler/codeGen/CgUpdate.lhs | 61 - ghc/compiler/codeGen/CgUsages.lhs | 170 - ghc/compiler/codeGen/CgUtils.hs | 622 +++ ghc/compiler/codeGen/ClosureInfo.lhs | 917 +--- ghc/compiler/codeGen/CodeGen.lhs | 353 +- ghc/compiler/codeGen/SMRep.lhs | 333 +- ghc/compiler/compMan/CompManager.lhs | 1 - ghc/compiler/deSugar/DsCCall.lhs | 4 +- ghc/compiler/deSugar/DsForeign.lhs | 8 +- ghc/compiler/ghci/ByteCodeAsm.lhs | 37 +- ghc/compiler/ghci/ByteCodeFFI.lhs | 59 +- ghc/compiler/ghci/ByteCodeGen.lhs | 162 +- ghc/compiler/ghci/ByteCodeInstr.lhs | 7 +- ghc/compiler/ghci/ByteCodeItbls.lhs | 10 +- ghc/compiler/ghci/InteractiveUI.hs | 4 +- ghc/compiler/ghci/Linker.lhs | 2 +- ghc/compiler/hsSyn/HsDecls.lhs | 3 +- ghc/compiler/main/CmdLineOpts.lhs | 6 +- ghc/compiler/main/CodeOutput.lhs | 38 +- ghc/compiler/main/Constants.lhs | 111 +- ghc/compiler/main/DriverFlags.hs | 8 +- ghc/compiler/main/DriverPhases.hs | 19 +- ghc/compiler/main/DriverPipeline.hs | 110 +- ghc/compiler/main/DriverState.hs | 8 +- ghc/compiler/main/DriverUtil.hs | 4 +- ghc/compiler/main/ErrUtils.lhs | 4 +- ghc/compiler/main/HscMain.lhs | 15 +- ghc/compiler/main/Main.hs | 10 +- ghc/compiler/main/SysTools.lhs | 2 +- ghc/compiler/nativeGen/AbsCStixGen.lhs | 694 --- ghc/compiler/nativeGen/AsmCodeGen.lhs | 1055 ++-- ghc/compiler/nativeGen/AsmRegAlloc.lhs | 941 ---- ghc/compiler/nativeGen/MachCode.lhs | 4628 ----------------- ghc/compiler/nativeGen/MachCodeGen.hs | 4203 +++++++++++++++ ghc/compiler/nativeGen/MachInstrs.hs | 693 +++ ghc/compiler/nativeGen/MachMisc.hi-boot | 8 - ghc/compiler/nativeGen/MachMisc.hi-boot-5 | 6 - ghc/compiler/nativeGen/MachMisc.hi-boot-6 | 7 - ghc/compiler/nativeGen/MachMisc.lhs | 789 --- ghc/compiler/nativeGen/MachRegs.lhs | 916 ++-- ghc/compiler/nativeGen/NCG.h | 84 +- ghc/compiler/nativeGen/NCGMonad.hs | 98 + ghc/compiler/nativeGen/NOTES | 52 +- .../nativeGen/{PprMach.lhs => PprMach.hs} | 814 +-- .../{RegAllocInfo.lhs => RegAllocInfo.hs} | 625 +-- ghc/compiler/nativeGen/RegisterAlloc.hs | 812 +++ ghc/compiler/nativeGen/Stix.hi-boot | 5 - ghc/compiler/nativeGen/Stix.lhs | 629 --- ghc/compiler/nativeGen/StixMacro.lhs | 291 -- ghc/compiler/nativeGen/StixPrim.hi-boot | 5 - ghc/compiler/nativeGen/StixPrim.hi-boot-5 | 3 - ghc/compiler/nativeGen/StixPrim.hi-boot-6 | 3 - ghc/compiler/nativeGen/StixPrim.lhs | 306 -- ghc/compiler/parser/Ctype.lhs | 26 + ghc/compiler/parser/Lexer.x | 128 +- ghc/compiler/parser/Parser.y.pp | 3 +- ghc/compiler/parser/RdrHsSyn.lhs | 3 +- ghc/compiler/prelude/ForeignCall.lhs | 24 +- ghc/compiler/prelude/PrimOp.lhs | 6 +- ghc/compiler/prelude/PrimRep.lhs | 240 - ghc/compiler/prelude/TysPrim.lhs | 14 +- ghc/compiler/profiling/CostCentre.lhs | 71 +- ghc/compiler/typecheck/TcForeign.lhs | 13 +- ghc/compiler/typecheck/TcHsSyn.lhs | 3 +- ghc/compiler/typecheck/TcRnTypes.lhs | 8 +- ghc/compiler/types/TyCon.lhs | 67 +- ghc/compiler/types/Type.lhs | 16 +- ghc/compiler/utils/FastString.lhs | 15 +- ghc/compiler/utils/OrdList.lhs | 9 + ghc/compiler/utils/Panic.lhs | 2 +- ghc/compiler/utils/StringBuffer.lhs | 12 + ghc/compiler/utils/Util.lhs | 70 +- ghc/docs/comm/genesis/modules.html | 4 +- ghc/docs/comm/rts-libs/coding-style.html | 2 +- ghc/driver/mangler/ghc-asm.lprl | 143 +- ghc/includes/Block.h | 44 +- ghc/includes/CCall.h | 141 - ghc/includes/ClosureMacros.h | 68 +- ghc/includes/Closures.h | 57 +- ghc/includes/Cmm.h | 465 ++ ghc/includes/Constants.h | 128 +- ghc/includes/Derived.h | 32 - ghc/includes/DietHEP.h | 13 - ghc/includes/HsFFI.h | 5 +- ghc/includes/InfoMacros.h | 692 --- ghc/includes/InfoTables.h | 34 +- ghc/includes/Liveness.h | 34 + ghc/includes/MachDeps.h | 3 +- ghc/includes/MachRegs.h | 8 +- ghc/includes/Makefile | 37 +- ghc/includes/PosixSource.h | 19 - ghc/includes/PrimOps.h | 421 -- ghc/includes/README | 114 + ghc/includes/Regs.h | 64 +- ghc/includes/Rts.h | 167 +- ghc/includes/RtsAPI.h | 11 +- ghc/includes/RtsConfig.h | 84 + ghc/includes/RtsExternal.h | 67 + ghc/includes/RtsFlags.h | 60 +- ghc/includes/Stable.h | 12 +- ghc/includes/Stg.h | 499 +- ghc/includes/StgFun.h | 32 +- ghc/includes/StgLdvProf.h | 84 +- ghc/includes/StgMacros.h | 851 --- ghc/includes/StgMiscClosures.h | 748 ++- ghc/includes/StgProf.h | 87 +- ghc/includes/StgStorage.h | 121 - ghc/includes/StgTicky.h | 161 +- ghc/includes/StgTypes.h | 23 +- ghc/{rts => includes}/Storage.h | 360 +- ghc/includes/TSO.h | 183 +- ghc/includes/TailCalls.h | 4 +- ghc/includes/Updates.h | 383 +- ghc/includes/mkDerivedConstants.c | 365 +- ghc/includes/mkNativeHdr.c | 117 - ghc/rts/Apply.cmm | 281 + ghc/rts/Apply.h | 77 +- ghc/rts/Apply.hc | 261 - ghc/rts/AutoApply.h | 80 + ghc/rts/Capability.h | 4 - ghc/rts/Disassembler.c | 7 +- ghc/rts/Exception.cmm | 396 ++ ghc/rts/Exception.h | 3 +- ghc/rts/Exception.hc | 469 -- ghc/rts/FrontPanel.c | 3 +- ghc/rts/GC.c | 81 +- ghc/rts/GCCompact.c | 31 +- ghc/rts/HeapStackCheck.cmm | 880 ++++ ghc/rts/HeapStackCheck.hc | 1062 ---- ghc/rts/Interpreter.c | 37 +- ghc/rts/LdvProfile.c | 3 +- ghc/rts/Linker.c | 104 +- ghc/rts/MBlock.h | 5 +- ghc/rts/Main.c | 6 +- ghc/rts/Makefile | 70 +- ghc/rts/Prelude.h | 108 +- ghc/rts/PrimOps.cmm | 1511 ++++++ ghc/rts/PrimOps.hc | 1749 ------- ghc/rts/Printer.c | 41 +- ghc/rts/ProfHeap.c | 3 +- ghc/rts/Profiling.c | 12 +- ghc/rts/Profiling.h | 4 +- ghc/rts/RetainerProfile.c | 36 +- ghc/rts/RetainerProfile.h | 4 +- ghc/rts/RtsFlags.c | 5 +- ghc/rts/RtsStartup.c | 49 +- ghc/rts/RtsUtils.h | 3 +- ghc/rts/Sanity.c | 26 +- ghc/rts/Schedule.c | 100 +- ghc/rts/Schedule.h | 26 +- ghc/rts/Signals.c | 3 +- ghc/rts/Stable.c | 3 +- ghc/rts/StablePriv.h | 17 - ghc/rts/Stats.c | 4 +- ghc/rts/StgCRun.c | 33 +- ghc/rts/StgMiscClosures.cmm | 984 ++++ ghc/rts/StgMiscClosures.hc | 1151 ---- ghc/rts/StgRun.h | 6 +- ghc/rts/{StgStartup.hc => StgStartup.cmm} | 184 +- ghc/rts/StgStartup.h | 17 - ghc/rts/StgStdThunks.cmm | 273 + ghc/rts/StgStdThunks.hc | 322 -- ghc/rts/Storage.c | 5 +- ghc/rts/StoragePriv.h | 94 - ghc/rts/Ticky.c | 105 +- ghc/rts/{Updates.hc => Updates.cmm} | 109 +- ghc/rts/Weak.c | 4 +- ghc/rts/Weak.h | 8 +- ghc/rts/package.conf.in | 4 +- ghc/utils/genapply/GenApply.hs | 355 +- ghc/utils/ghc-pkg/Main.hs | 2 +- ghc/utils/hp2ps/Main.h | 2 +- ghc/utils/hsc2hs/Main.hs | 2 +- ghc/utils/prof/cgprof/cgprof.c | 4 +- ghc/utils/prof/cgprof/main.c | 4 +- 218 files changed, 28337 insertions(+), 30102 deletions(-) delete mode 100644 ghc/compiler/absCSyn/AbsCSyn.lhs delete mode 100644 ghc/compiler/absCSyn/AbsCUtils.lhs delete mode 100644 ghc/compiler/absCSyn/CLabel.lhs delete mode 100644 ghc/compiler/absCSyn/CStrings.lhs delete mode 100644 ghc/compiler/absCSyn/Costs.lhs delete mode 100644 ghc/compiler/absCSyn/MachOp.hs delete mode 100644 ghc/compiler/absCSyn/PprAbsC.lhs create mode 100644 ghc/compiler/cmm/CLabel.hs create mode 100644 ghc/compiler/cmm/Cmm.hs create mode 100644 ghc/compiler/cmm/CmmLex.x create mode 100644 ghc/compiler/cmm/CmmLint.hs create mode 100644 ghc/compiler/cmm/CmmParse.y create mode 100644 ghc/compiler/cmm/CmmUtils.hs create mode 100644 ghc/compiler/cmm/MachOp.hs create mode 100644 ghc/compiler/cmm/PprC.hs create mode 100644 ghc/compiler/cmm/PprCmm.hs create mode 100644 ghc/compiler/codeGen/CgCallConv.hs delete mode 100644 ghc/compiler/codeGen/CgConTbls.lhs create mode 100644 ghc/compiler/codeGen/CgForeignCall.hs create mode 100644 ghc/compiler/codeGen/CgInfoTbls.hs create mode 100644 ghc/compiler/codeGen/CgParallel.hs create mode 100644 ghc/compiler/codeGen/CgPrimOp.hs create mode 100644 ghc/compiler/codeGen/CgProf.hs delete mode 100644 ghc/compiler/codeGen/CgRetConv.hi-boot delete mode 100644 ghc/compiler/codeGen/CgRetConv.lhs create mode 100644 ghc/compiler/codeGen/CgTicky.hs delete mode 100644 ghc/compiler/codeGen/CgUpdate.lhs delete mode 100644 ghc/compiler/codeGen/CgUsages.lhs create mode 100644 ghc/compiler/codeGen/CgUtils.hs delete mode 100644 ghc/compiler/nativeGen/AbsCStixGen.lhs delete mode 100644 ghc/compiler/nativeGen/AsmRegAlloc.lhs delete mode 100644 ghc/compiler/nativeGen/MachCode.lhs create mode 100644 ghc/compiler/nativeGen/MachCodeGen.hs create mode 100644 ghc/compiler/nativeGen/MachInstrs.hs delete mode 100644 ghc/compiler/nativeGen/MachMisc.hi-boot delete mode 100644 ghc/compiler/nativeGen/MachMisc.hi-boot-5 delete mode 100644 ghc/compiler/nativeGen/MachMisc.hi-boot-6 delete mode 100644 ghc/compiler/nativeGen/MachMisc.lhs create mode 100644 ghc/compiler/nativeGen/NCGMonad.hs rename ghc/compiler/nativeGen/{PprMach.lhs => PprMach.hs} (77%) rename ghc/compiler/nativeGen/{RegAllocInfo.lhs => RegAllocInfo.hs} (58%) create mode 100644 ghc/compiler/nativeGen/RegisterAlloc.hs delete mode 100644 ghc/compiler/nativeGen/Stix.hi-boot delete mode 100644 ghc/compiler/nativeGen/Stix.lhs delete mode 100644 ghc/compiler/nativeGen/StixMacro.lhs delete mode 100644 ghc/compiler/nativeGen/StixPrim.hi-boot delete mode 100644 ghc/compiler/nativeGen/StixPrim.hi-boot-5 delete mode 100644 ghc/compiler/nativeGen/StixPrim.hi-boot-6 delete mode 100644 ghc/compiler/nativeGen/StixPrim.lhs delete mode 100644 ghc/compiler/prelude/PrimRep.lhs delete mode 100644 ghc/includes/CCall.h create mode 100644 ghc/includes/Cmm.h delete mode 100644 ghc/includes/Derived.h delete mode 100644 ghc/includes/DietHEP.h delete mode 100644 ghc/includes/InfoMacros.h create mode 100644 ghc/includes/Liveness.h delete mode 100644 ghc/includes/PosixSource.h delete mode 100644 ghc/includes/PrimOps.h create mode 100644 ghc/includes/README create mode 100644 ghc/includes/RtsConfig.h create mode 100644 ghc/includes/RtsExternal.h delete mode 100644 ghc/includes/StgMacros.h delete mode 100644 ghc/includes/StgStorage.h rename ghc/{rts => includes}/Storage.h (54%) delete mode 100644 ghc/includes/mkNativeHdr.c create mode 100644 ghc/rts/Apply.cmm delete mode 100644 ghc/rts/Apply.hc create mode 100644 ghc/rts/AutoApply.h create mode 100644 ghc/rts/Exception.cmm delete mode 100644 ghc/rts/Exception.hc create mode 100644 ghc/rts/HeapStackCheck.cmm delete mode 100644 ghc/rts/HeapStackCheck.hc create mode 100644 ghc/rts/PrimOps.cmm delete mode 100644 ghc/rts/PrimOps.hc delete mode 100644 ghc/rts/StablePriv.h create mode 100644 ghc/rts/StgMiscClosures.cmm delete mode 100644 ghc/rts/StgMiscClosures.hc rename ghc/rts/{StgStartup.hc => StgStartup.cmm} (53%) delete mode 100644 ghc/rts/StgStartup.h create mode 100644 ghc/rts/StgStdThunks.cmm delete mode 100644 ghc/rts/StgStdThunks.hc delete mode 100644 ghc/rts/StoragePriv.h rename ghc/rts/{Updates.hc => Updates.cmm} (55%) diff --git a/ghc/compiler/HsVersions.h b/ghc/compiler/HsVersions.h index 1ba51b56a7..0bd9c142c4 100644 --- a/ghc/compiler/HsVersions.h +++ b/ghc/compiler/HsVersions.h @@ -66,10 +66,10 @@ name = Util.global (value) :: IORef (ty); \ #define WARN( e, msg ) (warnPprTrace (e) __FILE__ __LINE__ (msg)) #define ASSERTM(e) ASSERT(e) do #else -#define ASSERT(e) -#define ASSERT2(e,msg) +#define ASSERT(e) if False then error "ASSERT" else +#define ASSERT2(e,msg) if False then error "ASSERT2" else #define ASSERTM(e) -#define WARN(e,msg) +#define WARN(e,msg) if False then error "WARN" else #endif -- temporary usage assertion control KSW 2000-10 diff --git a/ghc/compiler/Makefile b/ghc/compiler/Makefile index b040e58665..ee40fc17c8 100644 --- a/ghc/compiler/Makefile +++ b/ghc/compiler/Makefile @@ -232,8 +232,8 @@ CLEAN_FILES += $(CONFIG_HS) ALL_DIRS = \ utils basicTypes types hsSyn prelude rename typecheck deSugar coreSyn \ - specialise simplCore stranal stgSyn simplStg codeGen absCSyn main \ - profiling parser cprAnalysis compMan ndpFlatten cbits iface + specialise simplCore stranal stgSyn simplStg codeGen main \ + profiling parser cprAnalysis compMan ndpFlatten cbits iface cmm # Make sure we include Config.hs even if it doesn't exist yet... ALL_SRCS += $(CONFIG_HS) @@ -410,9 +410,6 @@ ifeq "$(HOSTPLATFORM)" "i386-unknown-mingw32" main/SysTools_HC_OPTS += '-\#include ' '-\#include ' endif -# Required due to use of Concurrent.myThreadId -utils/Panic_HC_OPTS += -fvia-C - parser/Lexer_HC_OPTS += -funbox-strict-fields # ghc_strlen percolates through so many modules that it is easier to get its @@ -553,8 +550,6 @@ endif # typecheck/TcTyDecls_HC_OPTS += -auto-all # typecheck/TcType_HC_OPTS += -auto-all # typecheck/TcUnify_HC_OPTS += -auto-all -# -# absCSyn/PprAbsC_HC_OPTS += -auto-all coreSyn/CorePrep_HC_OPTS += -auto-all diff --git a/ghc/compiler/NOTES b/ghc/compiler/NOTES index 4c2b7024d7..8607f90e51 100644 --- a/ghc/compiler/NOTES +++ b/ghc/compiler/NOTES @@ -1,5 +1,47 @@ -* Can a scoped type variable denote a type scheme? + New back end thoughts +----------------------------------------------------------------------------- +Codegen notes + +* jumps to ImpossibleBranch should be removed. + +* Profiling: + - when updating a closure with an indirection to a function, + we should make a permanent indirection. + + - check that we're bumping the scc count appropriately + +* check perf & binary sizes against the HEAD + +----------------------------------------------------------------------------- +C backend notes + +* use STGCALL macros for foreign calls (doesn't look like volatile regs + are handled properly at the mo). + +----------------------------------------------------------------------------- +Cmm parser notes + +* switches + +* need to cater for unexported procedures/info tables? + +* We should be able to get rid of entry labels, use info labels only. + - we need a %ENTRY_LBL(info_lbl) macro, so that instead of + JMP_(foo_entry) we can write jump %ENTRY_LBL(foo_info). + +----------------------------------------------------------------------------- + +* Move arg-descr from LFInfo to ClosureInfo? + But: only needed for functions + +* Move all of CgClosure.link_caf into NewCaf, and newDynCaf + +* If the case binder is dead, and the constr is nullary, + do we need to assign to Node? + + +------------------------- * Relation between separate type sigs and pattern type sigs f :: forall a. a->a f :: b->b = e -- No: monomorphic diff --git a/ghc/compiler/absCSyn/AbsCSyn.lhs b/ghc/compiler/absCSyn/AbsCSyn.lhs deleted file mode 100644 index 3c8a470aae..0000000000 --- a/ghc/compiler/absCSyn/AbsCSyn.lhs +++ /dev/null @@ -1,540 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% -% $Id: AbsCSyn.lhs,v 1.56 2003/11/17 14:47:53 simonmar Exp $ -% -\section[AbstractC]{Abstract C: the last stop before machine code} - -This ``Abstract C'' data type describes the raw Spineless Tagless -machine model at a C-ish level; it is ``abstract'' in that it only -includes C-like structures that we happen to need. The conversion of -programs from @StgSyntax@ (basically a functional language) to -@AbstractC@ (basically imperative C) is the heart of code generation. -From @AbstractC@, one may convert to real C (for portability) or to -raw assembler/machine code. - -\begin{code} -module AbsCSyn where -- export everything - -#include "HsVersions.h" - -import {-# SOURCE #-} ClosureInfo ( ClosureInfo ) - -import CLabel -import Constants ( mAX_Vanilla_REG, mAX_Float_REG, - mAX_Double_REG, spRelToInt ) -import CostCentre ( CostCentre, CostCentreStack ) -import Literal ( mkMachInt, Literal(..) ) -import ForeignCall ( CCallSpec ) -import PrimRep ( PrimRep(..) ) -import MachOp ( MachOp(..) ) -import Unique ( Unique ) -import StgSyn ( StgOp ) -import TyCon ( TyCon ) -import Bitmap ( Bitmap, mAX_SMALL_BITMAP_SIZE ) -import SMRep ( StgWord, StgHalfWord ) -import FastTypes -import FastString -\end{code} - -@AbstractC@ is a list of Abstract~C statements, but the data structure -is tree-ish, for easier and more efficient putting-together. -\begin{code} -data AbstractC - = AbsCNop - | AbsCStmts AbstractC AbstractC - - -- and the individual stmts... -\end{code} - -A note on @CAssign@: In general, the type associated with an assignment -is the type of the lhs. However, when the lhs is a pointer to mixed -types (e.g. SpB relative), the type of the assignment is the type of -the rhs for float types, or the generic StgWord for all other types. -(In particular, a CharRep on the rhs is promoted to IntRep when -stored in a mixed type location.) - -\begin{code} - | CAssign - !CAddrMode -- target - !CAddrMode -- source - - | CJump - CAddrMode -- Put this in the program counter - -- eg `CJump (CReg (VanillaReg PtrRep 1))' puts Ret1 in PC - -- Enter can be done by: - -- CJump (CVal NodeRel zeroOff) - - | CFallThrough - CAddrMode -- Fall through into this routine - -- (for the benefit of the native code generators) - -- Equivalent to CJump in C land - - | CReturn -- Perform a return - CAddrMode -- Address of a RET_ info table - ReturnInfo -- Whether it's a direct or vectored return - - | CSwitch !CAddrMode - [(Literal, AbstractC)] -- alternatives - AbstractC -- default; if there is no real Abstract C in here - -- (e.g., all comments; see function "nonemptyAbsC"), - -- then that means the default _cannot_ occur. - -- If there is only one alternative & no default code, - -- then there is no need to check the tag. - -- Therefore, e.g.: - -- CSwitch m [(tag,code)] AbsCNop == code - - | CCodeBlock CLabel AbstractC - -- A labelled block of code; this "statement" is not - -- executed; rather, the labelled code will be hoisted - -- out to the top level (out of line) & it can be - -- jumped to. - - | CInitHdr -- to initialise the header of a closure (both fixed/var parts) - ClosureInfo - CAddrMode -- address of the info ptr - !CAddrMode -- cost centre to place in closure - -- CReg CurCostCentre or CC_HDR(R1.p{-Node-}) - Int -- size of closure, for profiling - - -- NEW CASES FOR EXPANDED PRIMOPS - - | CMachOpStmt -- Machine-level operation - CAddrMode -- result - MachOp - [CAddrMode] -- Arguments - (Maybe [MagicId]) -- list of regs which need to be preserved - -- across the primop. This is allowed to be Nothing only if - -- machOpIsDefinitelyInline returns True. And that in turn may - -- only return True if we are absolutely sure that the mach op - -- can be done inline on all platforms. - - | CSequential -- Do the nested AbstractCs sequentially. - [AbstractC] -- In particular, as far as the AbsCUtils.doSimultaneously - -- is concerned, these stmts are to be treated as atomic - -- and are not to be reordered. - - -- end of NEW CASES FOR EXPANDED PRIMOPS - - | COpStmt - [CAddrMode] -- Results - StgOp - [CAddrMode] -- Arguments - [MagicId] -- Potentially volatile/live registers - -- (to save/restore around the call/op) - - -- INVARIANT: When a PrimOp which can cause GC is used, the - -- only live data is tidily on the STG stacks or in the STG - -- registers (the code generator ensures this). - -- - -- Why this? Because if the arguments were arbitrary - -- addressing modes, they might be things like (Hp+6) which - -- will get utterly spongled by GC. - - | CSimultaneous -- Perform simultaneously all the statements - AbstractC -- in the nested AbstractC. They are only - -- allowed to be CAssigns, COpStmts and AbsCNops, so the - -- "simultaneous" part just concerns making - -- sure that permutations work. - -- For example { a := b, b := a } - -- needs to go via (at least one) temporary - - | CCheck -- heap or stack checks, or both. - CCheckMacro -- These might include some code to fill in tags - [CAddrMode] -- on the stack, so we can't use CMacroStmt below. - AbstractC - - | CRetDirect -- Direct return - !Unique -- for making labels - AbstractC -- return code - C_SRT -- SRT info - Liveness -- stack liveness at the return point - - -- see the notes about these next few; they follow below... - | CMacroStmt CStmtMacro [CAddrMode] - | CCallProfCtrMacro FastString [CAddrMode] - | CCallProfCCMacro FastString [CAddrMode] - - {- The presence of this constructor is a makeshift solution; - it being used to work around a gcc-related problem of - handling typedefs within statement blocks (or, rather, - the inability to do so.) - - The AbstractC flattener takes care of lifting out these - typedefs if needs be (i.e., when generating .hc code and - compiling 'foreign import dynamic's) - -} - | CCallTypedef Bool {- True => use "typedef"; False => use "extern"-} - CCallSpec Unique [CAddrMode] [CAddrMode] - - -- *** the next three [or so...] are DATA (those above are CODE) *** - - | CStaticClosure - CLabel -- The closure's label - ClosureInfo -- Todo: maybe info_lbl & closure_lbl instead? - CAddrMode -- cost centre identifier to place in closure - [CAddrMode] -- free vars; ptrs, then non-ptrs. - - | CSRT CLabel [CLabel] -- SRT declarations: basically an array of - -- pointers to static closures. - - | CBitmap Liveness -- A "large" bitmap to be emitted - - | CSRTDesc -- A "large" SRT descriptor (one that doesn't - -- fit into the half-word bitmap in the itbl). - !CLabel -- Label for this SRT descriptor - !CLabel -- Pointer to the SRT - !Int -- Offset within the SRT - !Int -- Length - !Bitmap -- Bitmap - - | CClosureInfoAndCode - ClosureInfo -- Explains placement and layout of closure - AbstractC -- Entry point code - - | CRetVector -- A labelled block of static data - CLabel - [CAddrMode] - C_SRT -- SRT info - Liveness -- stack liveness at the return point - - | CClosureTbl -- table of constructors for enumerated types - TyCon -- which TyCon this table is for - - | CModuleInitBlock -- module initialisation block - CLabel -- "plain" label for init block - CLabel -- label for init block (with ver + way info) - AbstractC -- initialisation code - - | CCostCentreDecl -- A cost centre *declaration* - Bool -- True <=> local => full declaration - -- False <=> extern; just say so - CostCentre - - | CCostCentreStackDecl -- A cost centre stack *declaration* - CostCentreStack -- this is the declaration for a - -- pre-defined singleton CCS (see - -- CostCentre.lhs) - - | CSplitMarker -- Split into separate object modules here - --- C_SRT is what StgSyn.SRT gets translated to... --- we add a label for the table, and expect only the 'offset/length' form - -data C_SRT = NoC_SRT - | C_SRT !CLabel !Int{-offset-} !StgHalfWord{-bitmap or escape-} - -needsSRT :: C_SRT -> Bool -needsSRT NoC_SRT = False -needsSRT (C_SRT _ _ _) = True -\end{code} - -About @CMacroStmt@, etc.: notionally, they all just call some -arbitrary C~macro or routine, passing the @CAddrModes@ as arguments. -However, we distinguish between various flavours of these things, -mostly just to keep things somewhat less wild and wooly. - -\begin{description} -\item[@CMacroStmt@:] -Some {\em essential} bits of the STG execution model are done with C -macros. An example is @STK_CHK@, which checks for stack-space -overflow. This enumeration type lists all such macros: -\begin{code} -data CStmtMacro - = UPD_CAF -- update CAF closure with indirection - | UPD_BH_UPDATABLE -- eager backholing - | UPD_BH_SINGLE_ENTRY -- more eager blackholing - | PUSH_UPD_FRAME -- push update frame - | SET_TAG -- set TagReg if it exists - -- dataToTag# primop -- *only* used in unregisterised builds. - -- (see AbsCUtils.dsCOpStmt) - | DATA_TO_TAGZH - - | REGISTER_FOREIGN_EXPORT -- register a foreign exported fun - | REGISTER_IMPORT -- register an imported module - | REGISTER_DIMPORT -- register an imported module from - -- another DLL - - | GRAN_FETCH -- for GrAnSim only -- HWL - | GRAN_RESCHEDULE -- for GrAnSim only -- HWL - | GRAN_FETCH_AND_RESCHEDULE -- for GrAnSim only -- HWL - | THREAD_CONTEXT_SWITCH -- for GrAnSim only -- HWL - | GRAN_YIELD -- for GrAnSim only -- HWL -\end{code} - -Heap/Stack checks. There are far too many of these. - -\begin{code} -data CCheckMacro - - = HP_CHK_NP -- heap/stack checks when - | STK_CHK_NP -- node points to the closure - | HP_STK_CHK_NP - - | HP_CHK_FUN -- heap/stack checks when - | STK_CHK_FUN -- node doesn't point - | HP_STK_CHK_FUN - -- case alternative heap checks: - - | HP_CHK_NOREGS -- no registers live - | HP_CHK_UNPT_R1 -- R1 is boxed/unlifted - | HP_CHK_UNBX_R1 -- R1 is unboxed - | HP_CHK_F1 -- FloatReg1 (only) is live - | HP_CHK_D1 -- DblReg1 (only) is live - | HP_CHK_L1 -- LngReg1 (only) is live - - | HP_CHK_UNBX_TUPLE -- unboxed tuple heap check -\end{code} - -\item[@CCallProfCtrMacro@:] -The @String@ names a macro that, if \tr{#define}d, will bump one/some -of the STG-event profiling counters. - -\item[@CCallProfCCMacro@:] -The @String@ names a macro that, if \tr{#define}d, will perform some -cost-centre-profiling-related action. -\end{description} - -%************************************************************************ -%* * -\subsection[CAddrMode]{C addressing modes} -%* * -%************************************************************************ - -\begin{code} -data CAddrMode - = CVal RegRelative PrimRep - -- On RHS of assign: Contents of Magic[n] - -- On LHS of assign: location Magic[n] - -- (ie at addr Magic+n) - - | CAddr RegRelative - -- On RHS of assign: Address of Magic[n]; ie Magic+n - -- n=0 gets the Magic location itself - -- (NB: n=0 case superceded by CReg) - -- On LHS of assign: only sensible if n=0, - -- which gives the magic location itself - -- (NB: superceded by CReg) - - -- JRS 2002-02-05: CAddr is really scummy and should be fixed. - -- The effect is that the semantics of CAddr depend on what the - -- contained RegRelative is; it is decidely non-orthogonal. - - | CReg MagicId -- To replace (CAddr MagicId 0) - - | CTemp !Unique !PrimRep -- Temporary locations - -- ``Temporaries'' correspond to local variables in C, and registers in - -- native code. - - | CLbl CLabel -- Labels in the runtime system, etc. - PrimRep -- the kind is so we can generate accurate C decls - - | CCharLike CAddrMode -- The address of a static char-like closure for - -- the specified character. It is guaranteed to be in - -- the range mIN_CHARLIKE..mAX_CHARLIKE - - | CIntLike CAddrMode -- The address of a static int-like closure for the - -- specified small integer. It is guaranteed to be in - -- the range mIN_INTLIKE..mAX_INTLIKE - - | CLit Literal - - | CJoinPoint -- This is used as the amode of a let-no-escape-bound - -- variable. - VirtualSpOffset -- Sp value after any volatile free vars - -- of the rhs have been saved on stack. - -- Just before the code for the thing is jumped to, - -- Sp will be set to this value, - -- and then any stack-passed args pushed, - -- then the code for this thing will be entered - | CMacroExpr - !PrimRep -- the kind of the result - CExprMacro -- the macro to generate a value - [CAddrMode] -- and its arguments -\end{code} - -Various C macros for values which are dependent on the back-end layout. - -\begin{code} - -data CExprMacro - = ENTRY_CODE - | ARG_TAG -- stack argument tagging - | GET_TAG -- get current constructor tag - | CCS_HDR - | BYTE_ARR_CTS -- used when passing a ByteArray# to a ccall - | PTRS_ARR_CTS -- similarly for an Array# - | ForeignObj_CLOSURE_DATA -- and again for a ForeignObj# -\end{code} - -Convenience functions: - -\begin{code} -mkIntCLit :: Int -> CAddrMode -mkIntCLit i = CLit (mkMachInt (toInteger i)) - -mkWordCLit :: StgWord -> CAddrMode -mkWordCLit wd = CLit (MachWord (fromIntegral wd)) - -mkCString :: FastString -> CAddrMode -mkCString s = CLit (MachStr s) - -mkCCostCentre :: CostCentre -> CAddrMode -mkCCostCentre cc = CLbl (mkCC_Label cc) DataPtrRep - -mkCCostCentreStack :: CostCentreStack -> CAddrMode -mkCCostCentreStack ccs = CLbl (mkCCS_Label ccs) DataPtrRep -\end{code} - -%************************************************************************ -%* * -\subsection[RegRelative]{@RegRelatives@: ???} -%* * -%************************************************************************ - -\begin{code} -data RegRelative - = HpRel FastInt -- } - | SpRel FastInt -- }- offsets in StgWords - | NodeRel FastInt -- } - | CIndex CAddrMode CAddrMode PrimRep -- pointer arithmetic :-) - -- CIndex a b k === (k*)a[b] - -data ReturnInfo - = DirectReturn -- Jump directly, if possible - | StaticVectoredReturn Int -- Fixed tag, starting at zero - | DynamicVectoredReturn CAddrMode -- Dynamic tag given by amode, starting at zero - -hpRel :: VirtualHeapOffset -- virtual offset of Hp - -> VirtualHeapOffset -- virtual offset of The Thing - -> RegRelative -- integer offset -hpRel hp off = HpRel (iUnbox (hp - off)) - -spRel :: VirtualSpOffset -- virtual offset of Sp - -> VirtualSpOffset -- virtual offset of The Thing - -> RegRelative -- integer offset -spRel sp off = SpRel (iUnbox (spRelToInt sp off)) - -nodeRel :: VirtualHeapOffset - -> RegRelative -nodeRel off = NodeRel (iUnbox off) - -\end{code} - -%************************************************************************ -%* * -\subsection[Liveness]{Liveness Masks} -%* * -%************************************************************************ - -We represent liveness bitmaps as a BitSet (whose internal -representation really is a bitmap). These are pinned onto case return -vectors to indicate the state of the stack for the garbage collector. - -In the compiled program, liveness bitmaps that fit inside a single -word (StgWord) are stored as a single word, while larger bitmaps are -stored as a pointer to an array of words. - -\begin{code} -data Liveness = Liveness CLabel !Int Bitmap - -maybeLargeBitmap :: Liveness -> AbstractC -maybeLargeBitmap liveness@(Liveness _ size _) - | size <= mAX_SMALL_BITMAP_SIZE = AbsCNop - | otherwise = CBitmap liveness -\end{code} - -%************************************************************************ -%* * -\subsection[HeapOffset]{@Heap Offsets@} -%* * -%************************************************************************ - -This used to be a grotesquely complicated datatype in an attempt to -hide the details of header sizes from the compiler itself. Now these -constants are imported from the RTS, and we deal in real Ints. - -\begin{code} -type HeapOffset = Int -- ToDo: remove - -type VirtualHeapOffset = HeapOffset -type VirtualSpOffset = Int -\end{code} - -%************************************************************************ -%* * -\subsection[MagicId]{@MagicIds@: registers and such} -%* * -%************************************************************************ - -\begin{code} -data MagicId - = BaseReg -- mentioned only in nativeGen - - -- Argument and return registers - | VanillaReg -- pointers, unboxed ints and chars - PrimRep - FastInt -- its number (1 .. mAX_Vanilla_REG) - - | FloatReg -- single-precision floating-point registers - FastInt -- its number (1 .. mAX_Float_REG) - - | DoubleReg -- double-precision floating-point registers - FastInt -- its number (1 .. mAX_Double_REG) - - -- STG registers - | Sp -- Stack ptr; points to last occupied stack location. - | SpLim -- Stack limit - | Hp -- Heap ptr; points to last occupied heap location. - | HpLim -- Heap limit register - | CurCostCentre -- current cost centre register. - | VoidReg -- see "VoidPrim" type; just a placeholder; - -- no actual register - | LongReg -- long int registers (64-bit, really) - PrimRep -- Int64Rep or Word64Rep - FastInt -- its number (1 .. mAX_Long_REG) - - | CurrentTSO -- pointer to current thread's TSO - | CurrentNursery -- pointer to allocation area - | HpAlloc -- allocation count for heap check failure - - -node = VanillaReg PtrRep (_ILIT 1) -- A convenient alias for Node -tagreg = VanillaReg WordRep (_ILIT 2) -- A convenient alias for TagReg - -nodeReg = CReg node -\end{code} - -We need magical @Eq@ because @VanillaReg@s come in multiple flavors. - -\begin{code} -instance Eq MagicId where - reg1 == reg2 = tag reg1 ==# tag reg2 - where - tag BaseReg = (_ILIT(0) :: FastInt) - tag Sp = _ILIT(1) - tag SpLim = _ILIT(3) - tag Hp = _ILIT(4) - tag HpLim = _ILIT(5) - tag CurCostCentre = _ILIT(6) - tag VoidReg = _ILIT(7) - - tag (VanillaReg _ i) = _ILIT(8) +# i - - tag (FloatReg i) = _ILIT(8) +# maxv +# i - tag (DoubleReg i) = _ILIT(8) +# maxv +# maxf +# i - tag (LongReg _ i) = _ILIT(8) +# maxv +# maxf +# maxd +# i - - maxv = iUnbox mAX_Vanilla_REG - maxf = iUnbox mAX_Float_REG - maxd = iUnbox mAX_Double_REG -\end{code} - -Returns True for any register that {\em potentially} dies across -C calls (or anything near equivalent). We just say @True@ and -let the (machine-specific) registering macros sort things out... - -\begin{code} -isVolatileReg :: MagicId -> Bool -isVolatileReg any = True -\end{code} diff --git a/ghc/compiler/absCSyn/AbsCUtils.lhs b/ghc/compiler/absCSyn/AbsCUtils.lhs deleted file mode 100644 index fef7bf56a7..0000000000 --- a/ghc/compiler/absCSyn/AbsCUtils.lhs +++ /dev/null @@ -1,1315 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 -% -\section[AbsCUtils]{Help functions for Abstract~C datatype} - -\begin{code} -module AbsCUtils ( - nonemptyAbsC, - mkAbstractCs, mkAbsCStmts, - mkAlgAltsCSwitch, - magicIdPrimRep, - getAmodeRep, - mixedTypeLocn, mixedPtrLocn, - flattenAbsC, - mkAbsCStmtList, - shimFCallArg - -- printing/forcing stuff comes from PprAbsC - ) where - -#include "HsVersions.h" -#include "../includes/config.h" - -import AbsCSyn -import Type ( tyConAppTyCon, repType ) -import TysPrim ( foreignObjPrimTyCon, arrayPrimTyCon, - byteArrayPrimTyCon, mutableByteArrayPrimTyCon, - mutableArrayPrimTyCon ) -import CLabel ( mkMAP_FROZEN_infoLabel ) -import Digraph ( stronglyConnComp, SCC(..) ) -import DataCon ( fIRST_TAG, dataConTag ) -import Literal ( literalPrimRep, mkMachWord, mkMachInt ) -import PrimRep ( getPrimRepSize, PrimRep(..) ) -import PrimOp ( PrimOp(..) ) -import MachOp ( MachOp(..), isDefinitelyInlineMachOp ) -import Unique ( Unique{-instance Eq-} ) -import UniqSupply ( uniqFromSupply, uniqsFromSupply, splitUniqSupply, - UniqSupply ) -import CmdLineOpts ( opt_EmitCExternDecls, opt_Unregisterised ) -import ForeignCall ( ForeignCall(..), CCallSpec(..), isDynamicTarget ) -import StgSyn ( StgOp(..), stgArgType ) -import CoreSyn ( AltCon(..) ) -import SMRep ( arrPtrsHdrSize, arrWordsHdrSize, fixedHdrSize ) -import Outputable -import Panic ( panic ) -import FastTypes -import Constants ( wORD_SIZE, wORD_SIZE_IN_BITS ) - -infixr 9 `thenFlt` -\end{code} - -Check if there is any real code in some Abstract~C. If so, return it -(@Just ...@); otherwise, return @Nothing@. Don't be too strict! - -It returns the "reduced" code in the Just part so that the work of -discarding AbsCNops isn't lost, and so that if the caller uses -the reduced version there's less danger of a big tree of AbsCNops getting -materialised and causing a space leak. - -\begin{code} -nonemptyAbsC :: AbstractC -> Maybe AbstractC -nonemptyAbsC AbsCNop = Nothing -nonemptyAbsC (AbsCStmts s1 s2) = case (nonemptyAbsC s1) of - Nothing -> nonemptyAbsC s2 - Just x -> Just (AbsCStmts x s2) -nonemptyAbsC s@(CSimultaneous c) = case (nonemptyAbsC c) of - Nothing -> Nothing - Just x -> Just s -nonemptyAbsC other = Just other -\end{code} - -\begin{code} -mkAbstractCs :: [AbstractC] -> AbstractC -mkAbstractCs [] = AbsCNop -mkAbstractCs cs = foldr1 mkAbsCStmts cs - --- for fiddling around w/ killing off AbsCNops ... (ToDo) -mkAbsCStmts :: AbstractC -> AbstractC -> AbstractC -mkAbsCStmts AbsCNop c = c -mkAbsCStmts c AbsCNop = c -mkAbsCStmts c1 c2 = c1 `AbsCStmts` c2 - -{- Discarded SLPJ June 95; it calls nonemptyAbsC too much! - = case (case (nonemptyAbsC abc2) of - Nothing -> AbsCNop - Just d2 -> d2) of { abc2b -> - - case (nonemptyAbsC abc1) of { - Nothing -> abc2b; - Just d1 -> AbsCStmts d1 abc2b - } } --} -\end{code} - -Get the sho' 'nuff statements out of an @AbstractC@. -\begin{code} -mkAbsCStmtList :: AbstractC -> [AbstractC] - -mkAbsCStmtList absC = mkAbsCStmtList' absC [] - --- Optimised a la foldr/build! - -mkAbsCStmtList' AbsCNop r = r - -mkAbsCStmtList' (AbsCStmts s1 s2) r - = mkAbsCStmtList' s1 (mkAbsCStmtList' s2 r) - -mkAbsCStmtList' s@(CSimultaneous c) r - = if null (mkAbsCStmtList c) then r else s : r - -mkAbsCStmtList' other r = other : r -\end{code} - -\begin{code} -mkAlgAltsCSwitch :: CAddrMode -> [(AltCon, AbstractC)] -> AbstractC - -mkAlgAltsCSwitch scrutinee ((_,first_alt) : rest_alts) - = CSwitch scrutinee (adjust rest_alts) first_alt - where - -- We use the first alt as the default. Either it *is* the DEFAULT, - -- (which is always first if present), or the case is exhaustive, - -- in which case we can use the first as the default anyway - - -- Adjust the tags in the switch to start at zero. - -- This is the convention used by primitive ops which return algebraic - -- data types. Why? Because for two-constructor types, zero is faster - -- to create and distinguish from 1 than are 1 and 2. - - -- We also need to convert to Literals to keep the CSwitch happy - adjust tagged_alts - = [ (mkMachWord (toInteger (dataConTag dc - fIRST_TAG)), abs_c) - | (DataAlt dc, abs_c) <- tagged_alts ] -\end{code} - -%************************************************************************ -%* * -\subsubsection[AbsCUtils-kinds-from-MagicIds]{Kinds from MagicIds} -%* * -%************************************************************************ - -\begin{code} -magicIdPrimRep BaseReg = PtrRep -magicIdPrimRep (VanillaReg kind _) = kind -magicIdPrimRep (FloatReg _) = FloatRep -magicIdPrimRep (DoubleReg _) = DoubleRep -magicIdPrimRep (LongReg kind _) = kind -magicIdPrimRep Sp = PtrRep -magicIdPrimRep SpLim = PtrRep -magicIdPrimRep Hp = PtrRep -magicIdPrimRep HpLim = PtrRep -magicIdPrimRep CurCostCentre = CostCentreRep -magicIdPrimRep VoidReg = VoidRep -magicIdPrimRep CurrentTSO = PtrRep -magicIdPrimRep CurrentNursery = PtrRep -magicIdPrimRep HpAlloc = WordRep -\end{code} - -%************************************************************************ -%* * -\subsection[AbsCUtils-amode-kinds]{Finding @PrimitiveKinds@ of amodes} -%* * -%************************************************************************ - -See also the return conventions for unboxed things; currently living -in @CgCon@ (next to the constructor return conventions). - -ToDo: tiny tweaking may be in order -\begin{code} -getAmodeRep :: CAddrMode -> PrimRep - -getAmodeRep (CVal _ kind) = kind -getAmodeRep (CAddr _) = PtrRep -getAmodeRep (CReg magic_id) = magicIdPrimRep magic_id -getAmodeRep (CTemp uniq kind) = kind -getAmodeRep (CLbl _ kind) = kind -getAmodeRep (CCharLike _) = PtrRep -getAmodeRep (CIntLike _) = PtrRep -getAmodeRep (CLit lit) = literalPrimRep lit -getAmodeRep (CMacroExpr kind _ _) = kind -getAmodeRep (CJoinPoint _) = panic "getAmodeRep:CJoinPoint" -\end{code} - -@mixedTypeLocn@ tells whether an amode identifies an ``StgWord'' -location; that is, one which can contain values of various types. - -\begin{code} -mixedTypeLocn :: CAddrMode -> Bool - -mixedTypeLocn (CVal (NodeRel _) _) = True -mixedTypeLocn (CVal (SpRel _) _) = True -mixedTypeLocn (CVal (HpRel _) _) = True -mixedTypeLocn other = False -- All the rest -\end{code} - -@mixedPtrLocn@ tells whether an amode identifies a -location which can contain values of various pointer types. - -\begin{code} -mixedPtrLocn :: CAddrMode -> Bool - -mixedPtrLocn (CVal (SpRel _) _) = True -mixedPtrLocn other = False -- All the rest -\end{code} - -%************************************************************************ -%* * -\subsection[AbsCUtils-flattening]{Flatten Abstract~C} -%* * -%************************************************************************ - -The following bits take ``raw'' Abstract~C, which may have all sorts of -nesting, and flattens it into one long @AbsCStmtList@. Mainly, -@CClosureInfos@ and code for switches are pulled out to the top level. - -The various functions herein tend to produce -\begin{enumerate} -\item -A {\em flattened} \tr{} of interest for ``here'', and -\item -Some {\em unflattened} Abstract~C statements to be carried up to the -top-level. The only real reason (now) that it is unflattened is -because it means the recursive flattening can be done in just one -place rather than having to remember lots of places. -\end{enumerate} - -Care is taken to reduce the occurrence of forward references, while still -keeping laziness a much as possible. Essentially, this means that: -\begin{itemize} -\item -{\em All} the top-level C statements resulting from flattening a -particular AbsC statement (whether the latter is nested or not) appear -before {\em any} of the code for a subsequent AbsC statement; -\item -but stuff nested within any AbsC statement comes -out before the code for the statement itself. -\end{itemize} - -The ``stuff to be carried up'' always includes a label: a -@CStaticClosure@, @CRetDirect@, @CFlatRetVector@, or -@CCodeBlock@. The latter turns into a C function, and is never -actually produced by the code generator. Rather it always starts life -as a @CCodeBlock@ addressing mode; when such an addr mode is -flattened, the ``tops'' stuff is a @CCodeBlock@. - -\begin{code} -flattenAbsC :: UniqSupply -> AbstractC -> AbstractC - -flattenAbsC us abs_C - = case (initFlt us (flatAbsC abs_C)) of { (here, tops) -> - here `mkAbsCStmts` tops } -\end{code} - -%************************************************************************ -%* * -\subsubsection{Flattening monadery} -%* * -%************************************************************************ - -The flattener is monadised. It's just a @UniqueSupply@. - -\begin{code} -type FlatM result = UniqSupply -> result - -initFlt :: UniqSupply -> FlatM a -> a - -initFlt init_us m = m init_us - -{-# INLINE thenFlt #-} -{-# INLINE returnFlt #-} - -thenFlt :: FlatM a -> (a -> FlatM b) -> FlatM b - -thenFlt expr cont us - = case (splitUniqSupply us) of { (s1, s2) -> - case (expr s1) of { result -> - cont result s2 }} - -returnFlt :: a -> FlatM a -returnFlt result us = result - -mapFlt :: (a -> FlatM b) -> [a] -> FlatM [b] - -mapFlt f [] = returnFlt [] -mapFlt f (x:xs) - = f x `thenFlt` \ r -> - mapFlt f xs `thenFlt` \ rs -> - returnFlt (r:rs) - -mapAndUnzipFlt :: (a -> FlatM (b,c)) -> [a] -> FlatM ([b],[c]) - -mapAndUnzipFlt f [] = returnFlt ([],[]) -mapAndUnzipFlt f (x:xs) - = f x `thenFlt` \ (r1, r2) -> - mapAndUnzipFlt f xs `thenFlt` \ (rs1, rs2) -> - returnFlt (r1:rs1, r2:rs2) - -getUniqFlt :: FlatM Unique -getUniqFlt us = uniqFromSupply us - -getUniqsFlt :: FlatM [Unique] -getUniqsFlt us = uniqsFromSupply us -\end{code} - -%************************************************************************ -%* * -\subsubsection{Flattening the top level} -%* * -%************************************************************************ - -\begin{code} -flatAbsC :: AbstractC - -> FlatM (AbstractC, -- Stuff to put inline [Both are fully - AbstractC) -- Stuff to put at top level flattened] - -flatAbsC AbsCNop = returnFlt (AbsCNop, AbsCNop) - -flatAbsC (AbsCStmts s1 s2) - = flatAbsC s1 `thenFlt` \ (inline_s1, top_s1) -> - flatAbsC s2 `thenFlt` \ (inline_s2, top_s2) -> - returnFlt (mkAbsCStmts inline_s1 inline_s2, - mkAbsCStmts top_s1 top_s2) - -flatAbsC (CClosureInfoAndCode cl_info entry) - = flatAbsC entry `thenFlt` \ (entry_heres, entry_tops) -> - returnFlt (AbsCNop, mkAbstractCs [entry_tops, - CClosureInfoAndCode cl_info entry_heres] - ) - -flatAbsC (CCodeBlock lbl abs_C) - = flatAbsC abs_C `thenFlt` \ (absC_heres, absC_tops) -> - returnFlt (AbsCNop, absC_tops `mkAbsCStmts` CCodeBlock lbl absC_heres) - -flatAbsC (CRetDirect uniq slow_code srt liveness) - = flatAbsC slow_code `thenFlt` \ (heres, tops) -> - returnFlt (AbsCNop, - mkAbstractCs [ tops, CRetDirect uniq heres srt liveness ]) - -flatAbsC (CSwitch discrim alts deflt) - = mapAndUnzipFlt flat_alt alts `thenFlt` \ (flat_alts, flat_alts_tops) -> - flatAbsC deflt `thenFlt` \ (flat_def_alt, def_tops) -> - returnFlt ( - CSwitch discrim flat_alts flat_def_alt, - mkAbstractCs (def_tops : flat_alts_tops) - ) - where - flat_alt (tag, absC) - = flatAbsC absC `thenFlt` \ (alt_heres, alt_tops) -> - returnFlt ( (tag, alt_heres), alt_tops ) - -flatAbsC stmt@(COpStmt results (StgFCallOp (CCall ccall@(CCallSpec target _ _)) uniq) args _) - | is_dynamic -- Emit a typedef if its a dynamic call - || (opt_EmitCExternDecls) -- or we want extern decls - = returnFlt (stmt, CCallTypedef is_dynamic ccall uniq results args) - where - is_dynamic = isDynamicTarget target - -flatAbsC stmt@(CSimultaneous abs_c) - = flatAbsC abs_c `thenFlt` \ (stmts_here, tops) -> - doSimultaneously stmts_here `thenFlt` \ new_stmts_here -> - returnFlt (new_stmts_here, tops) - -flatAbsC stmt@(CCheck macro amodes code) - = flatAbsC code `thenFlt` \ (code_here, code_tops) -> - returnFlt (CCheck macro amodes code_here, code_tops) - --- the TICKY_CTR macro always needs to be hoisted out to the top level. --- This is a HACK. -flatAbsC stmt@(CCallProfCtrMacro str amodes) - | str == FSLIT("TICK_CTR") = returnFlt (AbsCNop, stmt) - | otherwise = returnFlt (stmt, AbsCNop) - --- Some statements need no flattening at all: -flatAbsC stmt@(CMacroStmt macro amodes) = returnFlt (stmt, AbsCNop) -flatAbsC stmt@(CCallProfCCMacro str amodes) = returnFlt (stmt, AbsCNop) -flatAbsC stmt@(CAssign dest source) = returnFlt (stmt, AbsCNop) -flatAbsC stmt@(CJump target) = returnFlt (stmt, AbsCNop) -flatAbsC stmt@(CFallThrough target) = returnFlt (stmt, AbsCNop) -flatAbsC stmt@(CReturn target return_info) = returnFlt (stmt, AbsCNop) -flatAbsC stmt@(CInitHdr a b cc sz) = returnFlt (stmt, AbsCNop) -flatAbsC stmt@(CMachOpStmt res mop args m_vols) = returnFlt (stmt, AbsCNop) -flatAbsC stmt@(COpStmt results (StgFCallOp _ _) args vol_regs) - = returnFlt (stmt, AbsCNop) -flatAbsC stmt@(COpStmt results (StgPrimOp op) args vol_regs) - = dscCOpStmt (filter non_void_amode results) op - (filter non_void_amode args) vol_regs - `thenFlt` \ simpl -> - case simpl of - COpStmt _ _ _ _ -> panic "flatAbsC - dscCOpStmt" -- make sure we don't loop! - other -> flatAbsC other - {- - A gruesome hack for printing the names of inline primops when they - are used. - oink other - where - oink xxx - = getUniqFlt `thenFlt` \ uu -> - flatAbsC (CSequential [moo uu (showSDoc (ppr op)), xxx]) - - moo uu op_str - = COpStmt - [] - (StgFCallOp - (CCall (CCallSpec (CasmTarget (mkFastString (mktxt op_str))) - defaultCCallConv (PlaySafe False))) - uu - ) - [CReg VoidReg] - [] - mktxt op_str - = " asm(\"pushal;\"); printf(\"%%s\\n\",\"" ++ op_str ++ "\"); asm(\"popal\"); " - -} - -flatAbsC (CSequential abcs) - = mapAndUnzipFlt flatAbsC abcs `thenFlt` \ (inlines, tops) -> - returnFlt (CSequential inlines, foldr AbsCStmts AbsCNop tops) - - --- Some statements only make sense at the top level, so we always float --- them. This probably isn't necessary. -flatAbsC stmt@(CStaticClosure _ _ _ _) = returnFlt (AbsCNop, stmt) -flatAbsC stmt@(CClosureTbl _) = returnFlt (AbsCNop, stmt) -flatAbsC stmt@(CSRT _ _) = returnFlt (AbsCNop, stmt) -flatAbsC stmt@(CSRTDesc _ _ _ _ _) = returnFlt (AbsCNop, stmt) -flatAbsC stmt@(CBitmap _) = returnFlt (AbsCNop, stmt) -flatAbsC stmt@(CCostCentreDecl _ _) = returnFlt (AbsCNop, stmt) -flatAbsC stmt@(CCostCentreStackDecl _) = returnFlt (AbsCNop, stmt) -flatAbsC stmt@(CSplitMarker) = returnFlt (AbsCNop, stmt) -flatAbsC stmt@(CRetVector _ _ _ _) = returnFlt (AbsCNop, stmt) -flatAbsC stmt@(CModuleInitBlock _ _ _) = returnFlt (AbsCNop, stmt) -\end{code} - -%************************************************************************ -%* * -\subsection[flat-simultaneous]{Doing things simultaneously} -%* * -%************************************************************************ - -\begin{code} -doSimultaneously :: AbstractC -> FlatM AbstractC -\end{code} - -Generate code to perform the @CAssign@s and @COpStmt@s in the -input simultaneously, using temporary variables when necessary. - -We use the strongly-connected component algorithm, in which - * the vertices are the statements - * an edge goes from s1 to s2 iff - s1 assigns to something s2 uses - that is, if s1 should *follow* s2 in the final order - -\begin{code} -type CVertex = (Int, AbstractC) -- Give each vertex a unique number, - -- for fast comparison - -doSimultaneously abs_c - = let - enlisted = en_list abs_c - in - case enlisted of -- it's often just one stmt - [] -> returnFlt AbsCNop - [x] -> returnFlt x - _ -> doSimultaneously1 (zip [(1::Int)..] enlisted) - --- en_list puts all the assignments in a list, filtering out Nops and --- assignments which do nothing -en_list AbsCNop = [] -en_list (AbsCStmts a1 a2) = en_list a1 ++ en_list a2 -en_list (CAssign am1 am2) | sameAmode am1 am2 = [] -en_list other = [other] - -sameAmode :: CAddrMode -> CAddrMode -> Bool --- ToDo: Move this function, or make CAddrMode an instance of Eq --- At the moment we put in just enough to catch the cases we want: --- the second (destination) argument is always a CVal. -sameAmode (CReg r1) (CReg r2) = r1 == r2 -sameAmode (CVal (SpRel r1) _) (CVal (SpRel r2) _) = r1 ==# r2 -sameAmode other1 other2 = False - -doSimultaneously1 :: [CVertex] -> FlatM AbstractC -doSimultaneously1 vertices - = let - edges = [ (vertex, key1, edges_from stmt1) - | vertex@(key1, stmt1) <- vertices - ] - edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices, - stmt1 `should_follow` stmt2 - ] - components = stronglyConnComp edges - - -- do_components deal with one strongly-connected component - -- Not cyclic, or singleton? Just do it - do_component (AcyclicSCC (n,abs_c)) = returnFlt abs_c - do_component (CyclicSCC [(n,abs_c)]) = returnFlt abs_c - - -- Cyclic? Then go via temporaries. Pick one to - -- break the loop and try again with the rest. - do_component (CyclicSCC ((n,first_stmt) : rest)) - = doSimultaneously1 rest `thenFlt` \ abs_cs -> - go_via_temps first_stmt `thenFlt` \ (to_temps, from_temps) -> - returnFlt (mkAbstractCs [to_temps, abs_cs, from_temps]) - - go_via_temps (CAssign dest src) - = getUniqFlt `thenFlt` \ uniq -> - let - the_temp = CTemp uniq (getAmodeRep dest) - in - returnFlt (CAssign the_temp src, CAssign dest the_temp) - - go_via_temps (COpStmt dests op srcs vol_regs) - = getUniqsFlt `thenFlt` \ uniqs -> - let - the_temps = zipWith (\ u d -> CTemp u (getAmodeRep d)) uniqs dests - in - returnFlt (COpStmt the_temps op srcs vol_regs, - mkAbstractCs (zipWith CAssign dests the_temps)) - in - mapFlt do_component components `thenFlt` \ abs_cs -> - returnFlt (mkAbstractCs abs_cs) - - where - should_follow :: AbstractC -> AbstractC -> Bool - (CAssign dest1 _) `should_follow` (CAssign _ src2) - = dest1 `conflictsWith` src2 - (COpStmt dests1 _ _ _) `should_follow` (CAssign _ src2) - = or [dest1 `conflictsWith` src2 | dest1 <- dests1] - (CAssign dest1 _)`should_follow` (COpStmt _ _ srcs2 _) - = or [dest1 `conflictsWith` src2 | src2 <- srcs2] - (COpStmt dests1 _ _ _) `should_follow` (COpStmt _ _ srcs2 _) - = or [dest1 `conflictsWith` src2 | dest1 <- dests1, src2 <- srcs2] -\end{code} - -@conflictsWith@ tells whether an assignment to its first argument will -screw up an access to its second. - -\begin{code} -conflictsWith :: CAddrMode -> CAddrMode -> Bool -(CReg reg1) `conflictsWith` (CReg reg2) = reg1 == reg2 -(CReg reg) `conflictsWith` (CVal reg_rel _) = reg `regConflictsWithRR` reg_rel -(CReg reg) `conflictsWith` (CAddr reg_rel) = reg `regConflictsWithRR` reg_rel -(CTemp u1 _) `conflictsWith` (CTemp u2 _) = u1 == u2 -(CVal reg_rel1 k1) `conflictsWith` (CVal reg_rel2 k2) - = rrConflictsWithRR (getPrimRepSize k1) (getPrimRepSize k2) reg_rel1 reg_rel2 - -other1 `conflictsWith` other2 = False --- CAddr and literals are impossible on the LHS of an assignment - -regConflictsWithRR :: MagicId -> RegRelative -> Bool - -regConflictsWithRR (VanillaReg k n) (NodeRel _) | n ==# (_ILIT 1) = True -regConflictsWithRR Sp (SpRel _) = True -regConflictsWithRR Hp (HpRel _) = True -regConflictsWithRR _ _ = False - -rrConflictsWithRR :: Int -> Int -- Sizes of two things - -> RegRelative -> RegRelative -- The two amodes - -> Bool - -rrConflictsWithRR s1b s2b rr1 rr2 = rr rr1 rr2 - where - s1 = iUnbox s1b - s2 = iUnbox s2b - - rr (SpRel o1) (SpRel o2) - | s1 ==# (_ILIT 0) || s2 ==# (_ILIT 0) = False -- No conflict if either is size zero - | s1 ==# (_ILIT 1) && s2 ==# (_ILIT 1) = o1 ==# o2 - | otherwise = (o1 +# s1) >=# o2 && - (o2 +# s2) >=# o1 - - rr (NodeRel o1) (NodeRel o2) - | s1 ==# (_ILIT 0) || s2 ==# (_ILIT 0) = False -- No conflict if either is size zero - | s1 ==# (_ILIT 1) && s2 ==# (_ILIT 1) = o1 ==# o2 - | otherwise = True -- Give up - - rr (HpRel _) (HpRel _) = True -- Give up (ToDo) - - rr other1 other2 = False -\end{code} - -%************************************************************************ -%* * -\subsection[flat-primops]{Translating COpStmts to CMachOpStmts} -%* * -%************************************************************************ - -\begin{code} - --- We begin with some helper functions. The main Dude here is --- dscCOpStmt, defined a little further down. - ------------------------------------------------------------------------------- - --- Assumes no volatiles --- Creates --- res = arg >> (bits-per-word / 2) when little-endian --- or --- res = arg & ((1 << (bits-per-word / 2)) - 1) when big-endian --- --- In other words, if arg had been stored in memory, makes res the --- halfword of arg which would have had the higher address. This is --- why it needs to take into account endianness. --- -mkHalfWord_HIADDR res arg - = mkTemp WordRep `thenFlt` \ t_hw_mask1 -> - mkTemp WordRep `thenFlt` \ t_hw_mask2 -> - let - hw_shift = mkIntCLit (wORD_SIZE_IN_BITS `quot` 2) - -# if WORDS_BIGENDIAN - a_hw_mask1 - = CMachOpStmt t_hw_mask1 - MO_Nat_Shl [CLit (mkMachWord 1), hw_shift] Nothing - a_hw_mask2 - = CMachOpStmt t_hw_mask2 - MO_Nat_Sub [t_hw_mask1, CLit (mkMachWord 1)] Nothing - final - = CSequential [ a_hw_mask1, a_hw_mask2, - CMachOpStmt res MO_Nat_And [arg, t_hw_mask2] Nothing - ] -# else - final = CMachOpStmt res MO_Nat_Shr [arg, hw_shift] Nothing -# endif - in - returnFlt final - - -mkTemp :: PrimRep -> FlatM CAddrMode -mkTemp rep - = getUniqFlt `thenFlt` \ uniq -> returnFlt (CTemp uniq rep) - -mkTemps = mapFlt mkTemp - --- Sigh. This is done in 3 seperate places. Should be --- commoned up (here, in pprAbsC of COpStmt, and presumably --- somewhere in the NCG). -non_void_amode amode - = case getAmodeRep amode of - VoidRep -> False - k -> True - --- Helpers for translating various minor variants of array indexing. - -mkDerefOff :: PrimRep -> CAddrMode -> Int -> CAddrMode -mkDerefOff rep base off - = CVal (CIndex base (CLit (mkMachInt (toInteger off))) rep) rep - -mkNoDerefOff :: PrimRep -> CAddrMode -> Int -> CAddrMode -mkNoDerefOff rep base off - = CAddr (CIndex base (CLit (mkMachInt (toInteger off))) rep) - - --- Generates an address as follows --- base + sizeof(machine_word)*offw + sizeof(rep)*idx -mk_OSBI_addr :: Int -> PrimRep -> CAddrMode -> CAddrMode -> RegRelative -mk_OSBI_addr offw rep base idx - = CIndex (CAddr (CIndex base idx rep)) - (CLit (mkMachWord (fromIntegral offw))) - PtrRep - -mk_OSBI_ref :: Int -> PrimRep -> CAddrMode -> CAddrMode -> CAddrMode -mk_OSBI_ref offw rep base idx - = CVal (mk_OSBI_addr offw rep base idx) rep - - -doIndexOffForeignObjOp maybe_post_read_cast rep res addr idx - = mkBasicIndexedRead 0 maybe_post_read_cast rep res (mkDerefOff WordRep addr fixedHdrSize) idx - -doIndexOffAddrOp maybe_post_read_cast rep res addr idx - = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr idx - -doIndexByteArrayOp maybe_post_read_cast rep res addr idx - = mkBasicIndexedRead arrWordsHdrSize maybe_post_read_cast rep res addr idx - -doReadPtrArrayOp res addr idx - = mkBasicIndexedRead arrPtrsHdrSize Nothing PtrRep res addr idx - - -doWriteOffAddrOp maybe_pre_write_cast rep addr idx val - = mkBasicIndexedWrite 0 maybe_pre_write_cast rep addr idx val - -doWriteByteArrayOp maybe_pre_write_cast rep addr idx val - = mkBasicIndexedWrite arrWordsHdrSize maybe_pre_write_cast rep addr idx val - -doWritePtrArrayOp addr idx val - = mkBasicIndexedWrite arrPtrsHdrSize Nothing PtrRep addr idx val - - - -mkBasicIndexedRead offw Nothing read_rep res base idx - = returnFlt ( - CAssign res (mk_OSBI_ref offw read_rep base idx) - ) -mkBasicIndexedRead offw (Just cast_to_mop) read_rep res base idx - = mkTemp read_rep `thenFlt` \ tmp -> - (returnFlt . CSequential) [ - CAssign tmp (mk_OSBI_ref offw read_rep base idx), - CMachOpStmt res cast_to_mop [tmp] Nothing - ] - -mkBasicIndexedWrite offw Nothing write_rep base idx val - = returnFlt ( - CAssign (mk_OSBI_ref offw write_rep base idx) val - ) -mkBasicIndexedWrite offw (Just cast_to_mop) write_rep base idx val - = mkTemp write_rep `thenFlt` \ tmp -> - (returnFlt . CSequential) [ - CMachOpStmt tmp cast_to_mop [val] Nothing, - CAssign (mk_OSBI_ref offw write_rep base idx) tmp - ] - - --- Simple dyadic op but one for which we need to cast first arg to --- be sure of correctness -translateOp_dyadic_cast1 mop res cast_arg1_to arg1 arg2 vols - = mkTemp cast_arg1_to `thenFlt` \ arg1casted -> - (returnFlt . CSequential) [ - CAssign arg1casted arg1, - CMachOpStmt res mop [arg1casted,arg2] - (if isDefinitelyInlineMachOp mop then Nothing else Just vols) - ] - --- IA64 mangler doesn't place tables next to code -tablesNextToCode :: Bool -#ifdef ia64_TARGET_ARCH -tablesNextToCode = False -#else -tablesNextToCode = not opt_Unregisterised -#endif - ------------------------------------------------------------------------------- - --- This is the main top-level desugarer PrimOps into MachOps. First we --- handle various awkward cases specially. The remaining easy cases are --- then handled by translateOp, defined below. - - -dscCOpStmt :: [CAddrMode] -- Results - -> PrimOp - -> [CAddrMode] -- Arguments - -> [MagicId] -- Potentially volatile/live registers - -- (to save/restore around the op) - -> FlatM AbstractC - - -dscCOpStmt [res_r,res_c] IntAddCOp [aa,bb] vols -{- - With some bit-twiddling, we can define int{Add,Sub}Czh portably in - C, and without needing any comparisons. This may not be the - fastest way to do it - if you have better code, please send it! --SDM - - Return : r = a + b, c = 0 if no overflow, 1 on overflow. - - We currently don't make use of the r value if c is != 0 (i.e. - overflow), we just convert to big integers and try again. This - could be improved by making r and c the correct values for - plugging into a new J#. - - { r = ((I_)(a)) + ((I_)(b)); \ - c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \ - >> (BITS_IN (I_) - 1); \ - } - Wading through the mass of bracketry, it seems to reduce to: - c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1) - - SSA-form: - t1 = a^b - t2 = ~t1 - t3 = a^r - t4 = t2 & t3 - c = t4 >>unsigned BITS_IN(I_)-1 --} - = mkTemps [IntRep,IntRep,IntRep,IntRep] `thenFlt` \ [t1,t2,t3,t4] -> - let bpw1 = mkIntCLit (wORD_SIZE_IN_BITS - 1) in - (returnFlt . CSequential) [ - CMachOpStmt res_r MO_Nat_Add [aa,bb] Nothing, - CMachOpStmt t1 MO_Nat_Xor [aa,bb] Nothing, - CMachOpStmt t2 MO_Nat_Not [t1] Nothing, - CMachOpStmt t3 MO_Nat_Xor [aa,res_r] Nothing, - CMachOpStmt t4 MO_Nat_And [t2,t3] Nothing, - CMachOpStmt res_c MO_Nat_Shr [t4, bpw1] Nothing - ] - - -dscCOpStmt [res_r,res_c] IntSubCOp [aa,bb] vols -{- Similarly: - #define subIntCzh(r,c,a,b) \ - { r = ((I_)(a)) - ((I_)(b)); \ - c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \ - >> (BITS_IN (I_) - 1); \ - } - - c = ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1) - - t1 = a^b - t2 = a^r - t3 = t1 & t2 - c = t3 >>unsigned BITS_IN(I_)-1 --} - = mkTemps [IntRep,IntRep,IntRep] `thenFlt` \ [t1,t2,t3] -> - let bpw1 = mkIntCLit (wORD_SIZE_IN_BITS - 1) in - (returnFlt . CSequential) [ - CMachOpStmt res_r MO_Nat_Sub [aa,bb] Nothing, - CMachOpStmt t1 MO_Nat_Xor [aa,bb] Nothing, - CMachOpStmt t2 MO_Nat_Xor [aa,res_r] Nothing, - CMachOpStmt t3 MO_Nat_And [t1,t2] Nothing, - CMachOpStmt res_c MO_Nat_Shr [t3, bpw1] Nothing - ] - - --- #define parzh(r,node) r = 1 -dscCOpStmt [res] ParOp [arg] vols - = returnFlt - (CAssign res (CLit (mkMachInt 1))) - --- #define readMutVarzh(r,a) r=(P_)(((StgMutVar *)(a))->var) -dscCOpStmt [res] ReadMutVarOp [mutv] vols - = returnFlt - (CAssign res (mkDerefOff PtrRep mutv fixedHdrSize)) - --- #define writeMutVarzh(a,v) (P_)(((StgMutVar *)(a))->var)=(v) -dscCOpStmt [] WriteMutVarOp [mutv,var] vols - = returnFlt - (CAssign (mkDerefOff PtrRep mutv fixedHdrSize) var) - - --- #define ForeignObj_CLOSURE_DATA(c) (((StgForeignObj *)c)->data) --- #define foreignObjToAddrzh(r,fo) r=ForeignObj_CLOSURE_DATA(fo) -dscCOpStmt [res] ForeignObjToAddrOp [fo] vols - = returnFlt - (CAssign res (mkDerefOff PtrRep fo fixedHdrSize)) - --- #define writeForeignObjzh(res,datum) \ --- (ForeignObj_CLOSURE_DATA(res) = (P_)(datum)) -dscCOpStmt [] WriteForeignObjOp [fo,addr] vols - = returnFlt - (CAssign (mkDerefOff PtrRep fo fixedHdrSize) addr) - - --- #define sizzeofByteArrayzh(r,a) \ --- r = (((StgArrWords *)(a))->words * sizeof(W_)) -dscCOpStmt [res] SizeofByteArrayOp [arg] vols - = mkTemp WordRep `thenFlt` \ w -> - (returnFlt . CSequential) [ - CAssign w (mkDerefOff WordRep arg fixedHdrSize), - CMachOpStmt w MO_NatU_Mul [w, mkIntCLit wORD_SIZE] (Just vols), - CAssign res w - ] - --- #define sizzeofMutableByteArrayzh(r,a) \ --- r = (((StgArrWords *)(a))->words * sizeof(W_)) -dscCOpStmt [res] SizeofMutableByteArrayOp [arg] vols - = dscCOpStmt [res] SizeofByteArrayOp [arg] vols - - --- #define touchzh(o) /* nothing */ -dscCOpStmt [] TouchOp [arg] vols - = returnFlt AbsCNop - --- #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a) -dscCOpStmt [res] ByteArrayContents_Char [arg] vols - = mkTemp PtrRep `thenFlt` \ ptr -> - (returnFlt . CSequential) [ - CMachOpStmt ptr MO_NatU_to_NatP [arg] Nothing, - CAssign ptr (mkNoDerefOff WordRep ptr arrWordsHdrSize), - CAssign res ptr - ] - --- #define stableNameToIntzh(r,s) (r = ((StgStableName *)s)->sn) -dscCOpStmt [res] StableNameToIntOp [arg] vols - = returnFlt - (CAssign res (mkDerefOff WordRep arg fixedHdrSize)) - --- #define eqStableNamezh(r,sn1,sn2) \ --- (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn)) -dscCOpStmt [res] EqStableNameOp [arg1,arg2] vols - = mkTemps [WordRep, WordRep] `thenFlt` \ [sn1,sn2] -> - (returnFlt . CSequential) [ - CAssign sn1 (mkDerefOff WordRep arg1 fixedHdrSize), - CAssign sn2 (mkDerefOff WordRep arg2 fixedHdrSize), - CMachOpStmt res MO_Nat_Eq [sn1,sn2] Nothing - ] - -dscCOpStmt [res] ReallyUnsafePtrEqualityOp [arg1,arg2] vols - = mkTemps [WordRep, WordRep] `thenFlt` \ [w1,w2] -> - (returnFlt . CSequential) [ - CMachOpStmt w1 MO_NatP_to_NatU [arg1] Nothing, - CMachOpStmt w2 MO_NatP_to_NatU [arg2] Nothing, - CMachOpStmt res MO_Nat_Eq [w1,w2] Nothing{- because it's inline? -} - ] - --- #define addrToHValuezh(r,a) r=(P_)a -dscCOpStmt [res] AddrToHValueOp [arg] vols - = returnFlt - (CAssign res arg) - --- #define dataToTagzh(r,a) r=(GET_TAG(((StgClosure *)a)->header.info)) --- --- In the unregisterised case, we don't attempt to compute the location --- of the tag halfword, just a macro. For this build, fixing on layout --- info has only got drawbacks. --- --- Should this arrangement deeply offend you for some reason, code which --- computes the offset can be found below also. --- -- sof 3/02 --- -dscCOpStmt [res] DataToTagOp [arg] vols - | not tablesNextToCode - = returnFlt (CMacroStmt DATA_TO_TAGZH [res,arg]) - | otherwise - = mkTemps [PtrRep, WordRep] `thenFlt` \ [t_infoptr, t_theword] -> - mkHalfWord_HIADDR res t_theword `thenFlt` \ select_ops -> - (returnFlt . CSequential) [ - CAssign t_infoptr (mkDerefOff PtrRep arg 0), - {- - Get at the tag within the info table; two cases to consider: - - - reversed info tables next to the entry point code; - one word above the end of the info table (which is - what t_infoptr is really pointing to). - - info tables with their entry points stored somewhere else, - which is how the unregisterised (nee TABLES_NEXT_TO_CODE) - world operates. - - The t_infoptr points to the start of the info table, so add - the length of the info table & subtract one word. - -} - CAssign t_theword (mkDerefOff WordRep t_infoptr (-1)), -{- UNUSED - see above comment. - (if opt_Unregisterised then - (fixedItblSize - 1) - else (-1))), --} - select_ops - ] - - -{- Freezing arrays-of-ptrs requires changing an info table, for the - benefit of the generational collector. It needs to scavenge mutable - objects, even if they are in old space. When they become immutable, - they can be removed from this scavenge list. -} - --- #define unsafeFreezzeArrayzh(r,a) \ --- { \ --- SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN_info); \ --- r = a; \ --- } -dscCOpStmt [res] UnsafeFreezeArrayOp [arg] vols - = (returnFlt . CSequential) [ - CAssign (mkDerefOff PtrRep arg 0) (CLbl mkMAP_FROZEN_infoLabel PtrRep), - CAssign res arg - ] - --- #define unsafeFreezzeByteArrayzh(r,a) r=(a) -dscCOpStmt [res] UnsafeFreezeByteArrayOp [arg] vols - = returnFlt - (CAssign res arg) - --- This ought to be trivial, but it's difficult to insert the casts --- required to keep the C compiler happy. -dscCOpStmt [r] AddrRemOp [a1,a2] vols - = mkTemp WordRep `thenFlt` \ a1casted -> - (returnFlt . CSequential) [ - CMachOpStmt a1casted MO_NatP_to_NatU [a1] Nothing, - CMachOpStmt r MO_NatU_Rem [a1casted,a2] Nothing - ] - --- not handled by translateOp because they need casts -dscCOpStmt [r] SllOp [a1,a2] vols - = translateOp_dyadic_cast1 MO_Nat_Shl r WordRep a1 a2 vols -dscCOpStmt [r] SrlOp [a1,a2] vols - = translateOp_dyadic_cast1 MO_Nat_Shr r WordRep a1 a2 vols - -dscCOpStmt [r] ISllOp [a1,a2] vols - = translateOp_dyadic_cast1 MO_Nat_Shl r IntRep a1 a2 vols -dscCOpStmt [r] ISrlOp [a1,a2] vols - = translateOp_dyadic_cast1 MO_Nat_Shr r IntRep a1 a2 vols -dscCOpStmt [r] ISraOp [a1,a2] vols - = translateOp_dyadic_cast1 MO_Nat_Sar r IntRep a1 a2 vols - --- Reading/writing pointer arrays - -dscCOpStmt [r] ReadArrayOp [obj,ix] vols = doReadPtrArrayOp r obj ix -dscCOpStmt [r] IndexArrayOp [obj,ix] vols = doReadPtrArrayOp r obj ix -dscCOpStmt [] WriteArrayOp [obj,ix,v] vols = doWritePtrArrayOp obj ix v - --- IndexXXXoffForeignObj - -dscCOpStmt [r] IndexOffForeignObjOp_Char [a,i] vols = doIndexOffForeignObjOp (Just MO_8U_to_32U) Word8Rep r a i -dscCOpStmt [r] IndexOffForeignObjOp_WideChar [a,i] vols = doIndexOffForeignObjOp Nothing Word32Rep r a i -dscCOpStmt [r] IndexOffForeignObjOp_Int [a,i] vols = doIndexOffForeignObjOp Nothing IntRep r a i -dscCOpStmt [r] IndexOffForeignObjOp_Word [a,i] vols = doIndexOffForeignObjOp Nothing WordRep r a i -dscCOpStmt [r] IndexOffForeignObjOp_Addr [a,i] vols = doIndexOffForeignObjOp Nothing AddrRep r a i -dscCOpStmt [r] IndexOffForeignObjOp_Float [a,i] vols = doIndexOffForeignObjOp Nothing FloatRep r a i -dscCOpStmt [r] IndexOffForeignObjOp_Double [a,i] vols = doIndexOffForeignObjOp Nothing DoubleRep r a i -dscCOpStmt [r] IndexOffForeignObjOp_StablePtr [a,i] vols = doIndexOffForeignObjOp Nothing StablePtrRep r a i - -dscCOpStmt [r] IndexOffForeignObjOp_Int8 [a,i] vols = doIndexOffForeignObjOp Nothing Int8Rep r a i -dscCOpStmt [r] IndexOffForeignObjOp_Int16 [a,i] vols = doIndexOffForeignObjOp Nothing Int16Rep r a i -dscCOpStmt [r] IndexOffForeignObjOp_Int32 [a,i] vols = doIndexOffForeignObjOp Nothing Int32Rep r a i -dscCOpStmt [r] IndexOffForeignObjOp_Int64 [a,i] vols = doIndexOffForeignObjOp Nothing Int64Rep r a i - -dscCOpStmt [r] IndexOffForeignObjOp_Word8 [a,i] vols = doIndexOffForeignObjOp Nothing Word8Rep r a i -dscCOpStmt [r] IndexOffForeignObjOp_Word16 [a,i] vols = doIndexOffForeignObjOp Nothing Word16Rep r a i -dscCOpStmt [r] IndexOffForeignObjOp_Word32 [a,i] vols = doIndexOffForeignObjOp Nothing Word32Rep r a i -dscCOpStmt [r] IndexOffForeignObjOp_Word64 [a,i] vols = doIndexOffForeignObjOp Nothing Word64Rep r a i - --- IndexXXXoffAddr - -dscCOpStmt [r] IndexOffAddrOp_Char [a,i] vols = doIndexOffAddrOp (Just MO_8U_to_32U) Word8Rep r a i -dscCOpStmt [r] IndexOffAddrOp_WideChar [a,i] vols = doIndexOffAddrOp Nothing Word32Rep r a i -dscCOpStmt [r] IndexOffAddrOp_Int [a,i] vols = doIndexOffAddrOp Nothing IntRep r a i -dscCOpStmt [r] IndexOffAddrOp_Word [a,i] vols = doIndexOffAddrOp Nothing WordRep r a i -dscCOpStmt [r] IndexOffAddrOp_Addr [a,i] vols = doIndexOffAddrOp Nothing AddrRep r a i -dscCOpStmt [r] IndexOffAddrOp_Float [a,i] vols = doIndexOffAddrOp Nothing FloatRep r a i -dscCOpStmt [r] IndexOffAddrOp_Double [a,i] vols = doIndexOffAddrOp Nothing DoubleRep r a i -dscCOpStmt [r] IndexOffAddrOp_StablePtr [a,i] vols = doIndexOffAddrOp Nothing StablePtrRep r a i - -dscCOpStmt [r] IndexOffAddrOp_Int8 [a,i] vols = doIndexOffAddrOp Nothing Int8Rep r a i -dscCOpStmt [r] IndexOffAddrOp_Int16 [a,i] vols = doIndexOffAddrOp Nothing Int16Rep r a i -dscCOpStmt [r] IndexOffAddrOp_Int32 [a,i] vols = doIndexOffAddrOp Nothing Int32Rep r a i -dscCOpStmt [r] IndexOffAddrOp_Int64 [a,i] vols = doIndexOffAddrOp Nothing Int64Rep r a i - -dscCOpStmt [r] IndexOffAddrOp_Word8 [a,i] vols = doIndexOffAddrOp Nothing Word8Rep r a i -dscCOpStmt [r] IndexOffAddrOp_Word16 [a,i] vols = doIndexOffAddrOp Nothing Word16Rep r a i -dscCOpStmt [r] IndexOffAddrOp_Word32 [a,i] vols = doIndexOffAddrOp Nothing Word32Rep r a i -dscCOpStmt [r] IndexOffAddrOp_Word64 [a,i] vols = doIndexOffAddrOp Nothing Word64Rep r a i - --- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr. - -dscCOpStmt [r] ReadOffAddrOp_Char [a,i] vols = doIndexOffAddrOp (Just MO_8U_to_32U) Word8Rep r a i -dscCOpStmt [r] ReadOffAddrOp_WideChar [a,i] vols = doIndexOffAddrOp Nothing Word32Rep r a i -dscCOpStmt [r] ReadOffAddrOp_Int [a,i] vols = doIndexOffAddrOp Nothing IntRep r a i -dscCOpStmt [r] ReadOffAddrOp_Word [a,i] vols = doIndexOffAddrOp Nothing WordRep r a i -dscCOpStmt [r] ReadOffAddrOp_Addr [a,i] vols = doIndexOffAddrOp Nothing AddrRep r a i -dscCOpStmt [r] ReadOffAddrOp_Float [a,i] vols = doIndexOffAddrOp Nothing FloatRep r a i -dscCOpStmt [r] ReadOffAddrOp_Double [a,i] vols = doIndexOffAddrOp Nothing DoubleRep r a i -dscCOpStmt [r] ReadOffAddrOp_StablePtr [a,i] vols = doIndexOffAddrOp Nothing StablePtrRep r a i - -dscCOpStmt [r] ReadOffAddrOp_Int8 [a,i] vols = doIndexOffAddrOp Nothing Int8Rep r a i -dscCOpStmt [r] ReadOffAddrOp_Int16 [a,i] vols = doIndexOffAddrOp Nothing Int16Rep r a i -dscCOpStmt [r] ReadOffAddrOp_Int32 [a,i] vols = doIndexOffAddrOp Nothing Int32Rep r a i -dscCOpStmt [r] ReadOffAddrOp_Int64 [a,i] vols = doIndexOffAddrOp Nothing Int64Rep r a i - -dscCOpStmt [r] ReadOffAddrOp_Word8 [a,i] vols = doIndexOffAddrOp Nothing Word8Rep r a i -dscCOpStmt [r] ReadOffAddrOp_Word16 [a,i] vols = doIndexOffAddrOp Nothing Word16Rep r a i -dscCOpStmt [r] ReadOffAddrOp_Word32 [a,i] vols = doIndexOffAddrOp Nothing Word32Rep r a i -dscCOpStmt [r] ReadOffAddrOp_Word64 [a,i] vols = doIndexOffAddrOp Nothing Word64Rep r a i - --- IndexXXXArray - -dscCOpStmt [r] IndexByteArrayOp_Char [a,i] vols = doIndexByteArrayOp (Just MO_8U_to_32U) Word8Rep r a i -dscCOpStmt [r] IndexByteArrayOp_WideChar [a,i] vols = doIndexByteArrayOp Nothing Word32Rep r a i -dscCOpStmt [r] IndexByteArrayOp_Int [a,i] vols = doIndexByteArrayOp Nothing IntRep r a i -dscCOpStmt [r] IndexByteArrayOp_Word [a,i] vols = doIndexByteArrayOp Nothing WordRep r a i -dscCOpStmt [r] IndexByteArrayOp_Addr [a,i] vols = doIndexByteArrayOp Nothing AddrRep r a i -dscCOpStmt [r] IndexByteArrayOp_Float [a,i] vols = doIndexByteArrayOp Nothing FloatRep r a i -dscCOpStmt [r] IndexByteArrayOp_Double [a,i] vols = doIndexByteArrayOp Nothing DoubleRep r a i -dscCOpStmt [r] IndexByteArrayOp_StablePtr [a,i] vols = doIndexByteArrayOp Nothing StablePtrRep r a i - -dscCOpStmt [r] IndexByteArrayOp_Int8 [a,i] vols = doIndexByteArrayOp Nothing Int8Rep r a i -dscCOpStmt [r] IndexByteArrayOp_Int16 [a,i] vols = doIndexByteArrayOp Nothing Int16Rep r a i -dscCOpStmt [r] IndexByteArrayOp_Int32 [a,i] vols = doIndexByteArrayOp Nothing Int32Rep r a i -dscCOpStmt [r] IndexByteArrayOp_Int64 [a,i] vols = doIndexByteArrayOp Nothing Int64Rep r a i - -dscCOpStmt [r] IndexByteArrayOp_Word8 [a,i] vols = doIndexByteArrayOp Nothing Word8Rep r a i -dscCOpStmt [r] IndexByteArrayOp_Word16 [a,i] vols = doIndexByteArrayOp Nothing Word16Rep r a i -dscCOpStmt [r] IndexByteArrayOp_Word32 [a,i] vols = doIndexByteArrayOp Nothing Word32Rep r a i -dscCOpStmt [r] IndexByteArrayOp_Word64 [a,i] vols = doIndexByteArrayOp Nothing Word64Rep r a i - --- ReadXXXArray, identical to IndexXXXArray. - -dscCOpStmt [r] ReadByteArrayOp_Char [a,i] vols = doIndexByteArrayOp (Just MO_8U_to_32U) Word8Rep r a i -dscCOpStmt [r] ReadByteArrayOp_WideChar [a,i] vols = doIndexByteArrayOp Nothing Word32Rep r a i -dscCOpStmt [r] ReadByteArrayOp_Int [a,i] vols = doIndexByteArrayOp Nothing IntRep r a i -dscCOpStmt [r] ReadByteArrayOp_Word [a,i] vols = doIndexByteArrayOp Nothing WordRep r a i -dscCOpStmt [r] ReadByteArrayOp_Addr [a,i] vols = doIndexByteArrayOp Nothing AddrRep r a i -dscCOpStmt [r] ReadByteArrayOp_Float [a,i] vols = doIndexByteArrayOp Nothing FloatRep r a i -dscCOpStmt [r] ReadByteArrayOp_Double [a,i] vols = doIndexByteArrayOp Nothing DoubleRep r a i -dscCOpStmt [r] ReadByteArrayOp_StablePtr [a,i] vols = doIndexByteArrayOp Nothing StablePtrRep r a i - -dscCOpStmt [r] ReadByteArrayOp_Int8 [a,i] vols = doIndexByteArrayOp Nothing Int8Rep r a i -dscCOpStmt [r] ReadByteArrayOp_Int16 [a,i] vols = doIndexByteArrayOp Nothing Int16Rep r a i -dscCOpStmt [r] ReadByteArrayOp_Int32 [a,i] vols = doIndexByteArrayOp Nothing Int32Rep r a i -dscCOpStmt [r] ReadByteArrayOp_Int64 [a,i] vols = doIndexByteArrayOp Nothing Int64Rep r a i - -dscCOpStmt [r] ReadByteArrayOp_Word8 [a,i] vols = doIndexByteArrayOp Nothing Word8Rep r a i -dscCOpStmt [r] ReadByteArrayOp_Word16 [a,i] vols = doIndexByteArrayOp Nothing Word16Rep r a i -dscCOpStmt [r] ReadByteArrayOp_Word32 [a,i] vols = doIndexByteArrayOp Nothing Word32Rep r a i -dscCOpStmt [r] ReadByteArrayOp_Word64 [a,i] vols = doIndexByteArrayOp Nothing Word64Rep r a i - --- WriteXXXoffAddr - -dscCOpStmt [] WriteOffAddrOp_Char [a,i,x] vols = doWriteOffAddrOp (Just MO_32U_to_8U) Word8Rep a i x -dscCOpStmt [] WriteOffAddrOp_WideChar [a,i,x] vols = doWriteOffAddrOp Nothing Word32Rep a i x -dscCOpStmt [] WriteOffAddrOp_Int [a,i,x] vols = doWriteOffAddrOp Nothing IntRep a i x -dscCOpStmt [] WriteOffAddrOp_Word [a,i,x] vols = doWriteOffAddrOp Nothing WordRep a i x -dscCOpStmt [] WriteOffAddrOp_Addr [a,i,x] vols = doWriteOffAddrOp Nothing AddrRep a i x -dscCOpStmt [] WriteOffAddrOp_Float [a,i,x] vols = doWriteOffAddrOp Nothing FloatRep a i x -dscCOpStmt [] WriteOffAddrOp_ForeignObj [a,i,x] vols = doWriteOffAddrOp Nothing PtrRep a i x -dscCOpStmt [] WriteOffAddrOp_Double [a,i,x] vols = doWriteOffAddrOp Nothing DoubleRep a i x -dscCOpStmt [] WriteOffAddrOp_StablePtr [a,i,x] vols = doWriteOffAddrOp Nothing StablePtrRep a i x - -dscCOpStmt [] WriteOffAddrOp_Int8 [a,i,x] vols = doWriteOffAddrOp Nothing Int8Rep a i x -dscCOpStmt [] WriteOffAddrOp_Int16 [a,i,x] vols = doWriteOffAddrOp Nothing Int16Rep a i x -dscCOpStmt [] WriteOffAddrOp_Int32 [a,i,x] vols = doWriteOffAddrOp Nothing Int32Rep a i x -dscCOpStmt [] WriteOffAddrOp_Int64 [a,i,x] vols = doWriteOffAddrOp Nothing Int64Rep a i x - -dscCOpStmt [] WriteOffAddrOp_Word8 [a,i,x] vols = doWriteOffAddrOp Nothing Word8Rep a i x -dscCOpStmt [] WriteOffAddrOp_Word16 [a,i,x] vols = doWriteOffAddrOp Nothing Word16Rep a i x -dscCOpStmt [] WriteOffAddrOp_Word32 [a,i,x] vols = doWriteOffAddrOp Nothing Word32Rep a i x -dscCOpStmt [] WriteOffAddrOp_Word64 [a,i,x] vols = doWriteOffAddrOp Nothing Word64Rep a i x - --- WriteXXXArray - -dscCOpStmt [] WriteByteArrayOp_Char [a,i,x] vols = doWriteByteArrayOp (Just MO_32U_to_8U) Word8Rep a i x -dscCOpStmt [] WriteByteArrayOp_WideChar [a,i,x] vols = doWriteByteArrayOp Nothing Word32Rep a i x -dscCOpStmt [] WriteByteArrayOp_Int [a,i,x] vols = doWriteByteArrayOp Nothing IntRep a i x -dscCOpStmt [] WriteByteArrayOp_Word [a,i,x] vols = doWriteByteArrayOp Nothing WordRep a i x -dscCOpStmt [] WriteByteArrayOp_Addr [a,i,x] vols = doWriteByteArrayOp Nothing AddrRep a i x -dscCOpStmt [] WriteByteArrayOp_Float [a,i,x] vols = doWriteByteArrayOp Nothing FloatRep a i x -dscCOpStmt [] WriteByteArrayOp_Double [a,i,x] vols = doWriteByteArrayOp Nothing DoubleRep a i x -dscCOpStmt [] WriteByteArrayOp_StablePtr [a,i,x] vols = doWriteByteArrayOp Nothing StablePtrRep a i x - -dscCOpStmt [] WriteByteArrayOp_Int8 [a,i,x] vols = doWriteByteArrayOp Nothing Int8Rep a i x -dscCOpStmt [] WriteByteArrayOp_Int16 [a,i,x] vols = doWriteByteArrayOp Nothing Int16Rep a i x -dscCOpStmt [] WriteByteArrayOp_Int32 [a,i,x] vols = doWriteByteArrayOp Nothing Int32Rep a i x -dscCOpStmt [] WriteByteArrayOp_Int64 [a,i,x] vols = doWriteByteArrayOp Nothing Int64Rep a i x - -dscCOpStmt [] WriteByteArrayOp_Word8 [a,i,x] vols = doWriteByteArrayOp Nothing Word8Rep a i x -dscCOpStmt [] WriteByteArrayOp_Word16 [a,i,x] vols = doWriteByteArrayOp Nothing Word16Rep a i x -dscCOpStmt [] WriteByteArrayOp_Word32 [a,i,x] vols = doWriteByteArrayOp Nothing Word32Rep a i x -dscCOpStmt [] WriteByteArrayOp_Word64 [a,i,x] vols = doWriteByteArrayOp Nothing Word64Rep a i x - - --- Handle all others as simply as possible. -dscCOpStmt ress op args vols - = case translateOp ress op args of - Nothing - -> pprPanic "dscCOpStmt: can't translate PrimOp" (ppr op) - Just (maybe_res, mop, args) - -> returnFlt ( - CMachOpStmt maybe_res mop args - (if isDefinitelyInlineMachOp mop then Nothing else Just vols) - ) - --- Native word signless ops - -translateOp [r] IntAddOp [a1,a2] = Just (r, MO_Nat_Add, [a1,a2]) -translateOp [r] IntSubOp [a1,a2] = Just (r, MO_Nat_Sub, [a1,a2]) -translateOp [r] WordAddOp [a1,a2] = Just (r, MO_Nat_Add, [a1,a2]) -translateOp [r] WordSubOp [a1,a2] = Just (r, MO_Nat_Sub, [a1,a2]) -translateOp [r] AddrAddOp [a1,a2] = Just (r, MO_Nat_Add, [a1,a2]) -translateOp [r] AddrSubOp [a1,a2] = Just (r, MO_Nat_Sub, [a1,a2]) - -translateOp [r] IntEqOp [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2]) -translateOp [r] IntNeOp [a1,a2] = Just (r, MO_Nat_Ne, [a1,a2]) -translateOp [r] WordEqOp [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2]) -translateOp [r] WordNeOp [a1,a2] = Just (r, MO_Nat_Ne, [a1,a2]) -translateOp [r] AddrEqOp [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2]) -translateOp [r] AddrNeOp [a1,a2] = Just (r, MO_Nat_Ne, [a1,a2]) - -translateOp [r] AndOp [a1,a2] = Just (r, MO_Nat_And, [a1,a2]) -translateOp [r] OrOp [a1,a2] = Just (r, MO_Nat_Or, [a1,a2]) -translateOp [r] XorOp [a1,a2] = Just (r, MO_Nat_Xor, [a1,a2]) -translateOp [r] NotOp [a1] = Just (r, MO_Nat_Not, [a1]) - --- Native word signed ops - -translateOp [r] IntMulOp [a1,a2] = Just (r, MO_NatS_Mul, [a1,a2]) -translateOp [r] IntMulMayOfloOp [a1,a2] = Just (r, MO_NatS_MulMayOflo, [a1,a2]) -translateOp [r] IntQuotOp [a1,a2] = Just (r, MO_NatS_Quot, [a1,a2]) -translateOp [r] IntRemOp [a1,a2] = Just (r, MO_NatS_Rem, [a1,a2]) -translateOp [r] IntNegOp [a1] = Just (r, MO_NatS_Neg, [a1]) - -translateOp [r] IntGeOp [a1,a2] = Just (r, MO_NatS_Ge, [a1,a2]) -translateOp [r] IntLeOp [a1,a2] = Just (r, MO_NatS_Le, [a1,a2]) -translateOp [r] IntGtOp [a1,a2] = Just (r, MO_NatS_Gt, [a1,a2]) -translateOp [r] IntLtOp [a1,a2] = Just (r, MO_NatS_Lt, [a1,a2]) - - --- Native word unsigned ops - -translateOp [r] WordGeOp [a1,a2] = Just (r, MO_NatU_Ge, [a1,a2]) -translateOp [r] WordLeOp [a1,a2] = Just (r, MO_NatU_Le, [a1,a2]) -translateOp [r] WordGtOp [a1,a2] = Just (r, MO_NatU_Gt, [a1,a2]) -translateOp [r] WordLtOp [a1,a2] = Just (r, MO_NatU_Lt, [a1,a2]) - -translateOp [r] WordMulOp [a1,a2] = Just (r, MO_NatU_Mul, [a1,a2]) -translateOp [r] WordQuotOp [a1,a2] = Just (r, MO_NatU_Quot, [a1,a2]) -translateOp [r] WordRemOp [a1,a2] = Just (r, MO_NatU_Rem, [a1,a2]) - -translateOp [r] AddrGeOp [a1,a2] = Just (r, MO_NatU_Ge, [a1,a2]) -translateOp [r] AddrLeOp [a1,a2] = Just (r, MO_NatU_Le, [a1,a2]) -translateOp [r] AddrGtOp [a1,a2] = Just (r, MO_NatU_Gt, [a1,a2]) -translateOp [r] AddrLtOp [a1,a2] = Just (r, MO_NatU_Lt, [a1,a2]) - --- 32-bit unsigned ops - -translateOp [r] CharEqOp [a1,a2] = Just (r, MO_32U_Eq, [a1,a2]) -translateOp [r] CharNeOp [a1,a2] = Just (r, MO_32U_Ne, [a1,a2]) -translateOp [r] CharGeOp [a1,a2] = Just (r, MO_32U_Ge, [a1,a2]) -translateOp [r] CharLeOp [a1,a2] = Just (r, MO_32U_Le, [a1,a2]) -translateOp [r] CharGtOp [a1,a2] = Just (r, MO_32U_Gt, [a1,a2]) -translateOp [r] CharLtOp [a1,a2] = Just (r, MO_32U_Lt, [a1,a2]) - --- Double ops - -translateOp [r] DoubleEqOp [a1,a2] = Just (r, MO_Dbl_Eq, [a1,a2]) -translateOp [r] DoubleNeOp [a1,a2] = Just (r, MO_Dbl_Ne, [a1,a2]) -translateOp [r] DoubleGeOp [a1,a2] = Just (r, MO_Dbl_Ge, [a1,a2]) -translateOp [r] DoubleLeOp [a1,a2] = Just (r, MO_Dbl_Le, [a1,a2]) -translateOp [r] DoubleGtOp [a1,a2] = Just (r, MO_Dbl_Gt, [a1,a2]) -translateOp [r] DoubleLtOp [a1,a2] = Just (r, MO_Dbl_Lt, [a1,a2]) - -translateOp [r] DoubleAddOp [a1,a2] = Just (r, MO_Dbl_Add, [a1,a2]) -translateOp [r] DoubleSubOp [a1,a2] = Just (r, MO_Dbl_Sub, [a1,a2]) -translateOp [r] DoubleMulOp [a1,a2] = Just (r, MO_Dbl_Mul, [a1,a2]) -translateOp [r] DoubleDivOp [a1,a2] = Just (r, MO_Dbl_Div, [a1,a2]) -translateOp [r] DoublePowerOp [a1,a2] = Just (r, MO_Dbl_Pwr, [a1,a2]) - -translateOp [r] DoubleSinOp [a1] = Just (r, MO_Dbl_Sin, [a1]) -translateOp [r] DoubleCosOp [a1] = Just (r, MO_Dbl_Cos, [a1]) -translateOp [r] DoubleTanOp [a1] = Just (r, MO_Dbl_Tan, [a1]) -translateOp [r] DoubleSinhOp [a1] = Just (r, MO_Dbl_Sinh, [a1]) -translateOp [r] DoubleCoshOp [a1] = Just (r, MO_Dbl_Cosh, [a1]) -translateOp [r] DoubleTanhOp [a1] = Just (r, MO_Dbl_Tanh, [a1]) -translateOp [r] DoubleAsinOp [a1] = Just (r, MO_Dbl_Asin, [a1]) -translateOp [r] DoubleAcosOp [a1] = Just (r, MO_Dbl_Acos, [a1]) -translateOp [r] DoubleAtanOp [a1] = Just (r, MO_Dbl_Atan, [a1]) -translateOp [r] DoubleLogOp [a1] = Just (r, MO_Dbl_Log, [a1]) -translateOp [r] DoubleExpOp [a1] = Just (r, MO_Dbl_Exp, [a1]) -translateOp [r] DoubleSqrtOp [a1] = Just (r, MO_Dbl_Sqrt, [a1]) -translateOp [r] DoubleNegOp [a1] = Just (r, MO_Dbl_Neg, [a1]) - --- Float ops - -translateOp [r] FloatEqOp [a1,a2] = Just (r, MO_Flt_Eq, [a1,a2]) -translateOp [r] FloatNeOp [a1,a2] = Just (r, MO_Flt_Ne, [a1,a2]) -translateOp [r] FloatGeOp [a1,a2] = Just (r, MO_Flt_Ge, [a1,a2]) -translateOp [r] FloatLeOp [a1,a2] = Just (r, MO_Flt_Le, [a1,a2]) -translateOp [r] FloatGtOp [a1,a2] = Just (r, MO_Flt_Gt, [a1,a2]) -translateOp [r] FloatLtOp [a1,a2] = Just (r, MO_Flt_Lt, [a1,a2]) - -translateOp [r] FloatAddOp [a1,a2] = Just (r, MO_Flt_Add, [a1,a2]) -translateOp [r] FloatSubOp [a1,a2] = Just (r, MO_Flt_Sub, [a1,a2]) -translateOp [r] FloatMulOp [a1,a2] = Just (r, MO_Flt_Mul, [a1,a2]) -translateOp [r] FloatDivOp [a1,a2] = Just (r, MO_Flt_Div, [a1,a2]) -translateOp [r] FloatPowerOp [a1,a2] = Just (r, MO_Flt_Pwr, [a1,a2]) - -translateOp [r] FloatSinOp [a1] = Just (r, MO_Flt_Sin, [a1]) -translateOp [r] FloatCosOp [a1] = Just (r, MO_Flt_Cos, [a1]) -translateOp [r] FloatTanOp [a1] = Just (r, MO_Flt_Tan, [a1]) -translateOp [r] FloatSinhOp [a1] = Just (r, MO_Flt_Sinh, [a1]) -translateOp [r] FloatCoshOp [a1] = Just (r, MO_Flt_Cosh, [a1]) -translateOp [r] FloatTanhOp [a1] = Just (r, MO_Flt_Tanh, [a1]) -translateOp [r] FloatAsinOp [a1] = Just (r, MO_Flt_Asin, [a1]) -translateOp [r] FloatAcosOp [a1] = Just (r, MO_Flt_Acos, [a1]) -translateOp [r] FloatAtanOp [a1] = Just (r, MO_Flt_Atan, [a1]) -translateOp [r] FloatLogOp [a1] = Just (r, MO_Flt_Log, [a1]) -translateOp [r] FloatExpOp [a1] = Just (r, MO_Flt_Exp, [a1]) -translateOp [r] FloatSqrtOp [a1] = Just (r, MO_Flt_Sqrt, [a1]) -translateOp [r] FloatNegOp [a1] = Just (r, MO_Flt_Neg, [a1]) - --- Conversions - -translateOp [r] Int2DoubleOp [a1] = Just (r, MO_NatS_to_Dbl, [a1]) -translateOp [r] Double2IntOp [a1] = Just (r, MO_Dbl_to_NatS, [a1]) - -translateOp [r] Int2FloatOp [a1] = Just (r, MO_NatS_to_Flt, [a1]) -translateOp [r] Float2IntOp [a1] = Just (r, MO_Flt_to_NatS, [a1]) - -translateOp [r] Float2DoubleOp [a1] = Just (r, MO_Flt_to_Dbl, [a1]) -translateOp [r] Double2FloatOp [a1] = Just (r, MO_Dbl_to_Flt, [a1]) - -translateOp [r] Int2WordOp [a1] = Just (r, MO_NatS_to_NatU, [a1]) -translateOp [r] Word2IntOp [a1] = Just (r, MO_NatU_to_NatS, [a1]) - -translateOp [r] Int2AddrOp [a1] = Just (r, MO_NatS_to_NatP, [a1]) -translateOp [r] Addr2IntOp [a1] = Just (r, MO_NatP_to_NatS, [a1]) - -translateOp [r] OrdOp [a1] = Just (r, MO_32U_to_NatS, [a1]) -translateOp [r] ChrOp [a1] = Just (r, MO_NatS_to_32U, [a1]) - -translateOp [r] Narrow8IntOp [a1] = Just (r, MO_8S_to_NatS, [a1]) -translateOp [r] Narrow16IntOp [a1] = Just (r, MO_16S_to_NatS, [a1]) -translateOp [r] Narrow32IntOp [a1] = Just (r, MO_32S_to_NatS, [a1]) - -translateOp [r] Narrow8WordOp [a1] = Just (r, MO_8U_to_NatU, [a1]) -translateOp [r] Narrow16WordOp [a1] = Just (r, MO_16U_to_NatU, [a1]) -translateOp [r] Narrow32WordOp [a1] = Just (r, MO_32U_to_NatU, [a1]) - --- Word comparisons masquerading as more exotic things. - -translateOp [r] SameMutVarOp [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2]) -translateOp [r] SameMVarOp [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2]) -translateOp [r] SameMutableArrayOp [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2]) -translateOp [r] SameMutableByteArrayOp [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2]) -translateOp [r] EqForeignObj [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2]) -translateOp [r] EqStablePtrOp [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2]) - -translateOp _ _ _ = Nothing -\end{code} - - -\begin{code} -shimFCallArg arg amode - | tycon == foreignObjPrimTyCon - = CMacroExpr AddrRep ForeignObj_CLOSURE_DATA [amode] - | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon - = CMacroExpr PtrRep PTRS_ARR_CTS [amode] - | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon - = CMacroExpr AddrRep BYTE_ARR_CTS [amode] - | otherwise = amode - where - -- should be a tycon app, since this is a foreign call - tycon = tyConAppTyCon (repType (stgArgType arg)) -\end{code} diff --git a/ghc/compiler/absCSyn/CLabel.lhs b/ghc/compiler/absCSyn/CLabel.lhs deleted file mode 100644 index f2b3ff9832..0000000000 --- a/ghc/compiler/absCSyn/CLabel.lhs +++ /dev/null @@ -1,596 +0,0 @@ -% -% (c) The University of Glasgow, 1992-2002 -% -\section[CLabel]{@CLabel@: Information to make C Labels} - -\begin{code} -module CLabel ( - CLabel, -- abstract type - - mkClosureLabel, - mkSRTLabel, - mkSRTDescLabel, - mkInfoTableLabel, - mkEntryLabel, - mkSlowEntryLabel, - mkConEntryLabel, - mkStaticConEntryLabel, - mkRednCountsLabel, - mkConInfoTableLabel, - mkStaticInfoTableLabel, - mkApEntryLabel, - mkApInfoTableLabel, - - mkReturnPtLabel, - mkReturnInfoLabel, - mkVecTblLabel, - mkAltLabel, - mkDefaultLabel, - mkBitmapLabel, - - mkClosureTblLabel, - - mkAsmTempLabel, - - mkModuleInitLabel, - mkPlainModuleInitLabel, - - mkErrorStdEntryLabel, - - mkStgUpdatePAPLabel, - mkSplitMarkerLabel, - mkUpdInfoLabel, - mkSeqInfoLabel, - mkIndInfoLabel, - mkIndStaticInfoLabel, - mkRtsGCEntryLabel, - mkMainCapabilityLabel, - mkCharlikeClosureLabel, - mkIntlikeClosureLabel, - mkMAP_FROZEN_infoLabel, - mkEMPTY_MVAR_infoLabel, - - mkTopTickyCtrLabel, - mkBlackHoleInfoTableLabel, - mkBlackHoleBQInfoTableLabel, - mkCAFBlackHoleInfoTableLabel, - mkSECAFBlackHoleInfoTableLabel, - mkRtsPrimOpLabel, - - moduleRegdLabel, - - mkSelectorInfoLabel, - mkSelectorEntryLabel, - - mkRtsApplyInfoLabel, - mkRtsApplyEntryLabel, - - mkForeignLabel, - - mkCC_Label, mkCCS_Label, - - needsCDecl, isAsmTemp, externallyVisibleCLabel, - - CLabelType(..), labelType, labelDynamic, - - pprCLabel - ) where - - -#include "HsVersions.h" - -#if ! OMIT_NATIVE_CODEGEN -import {-# SOURCE #-} MachMisc ( underscorePrefix, fmtAsmLbl ) -#endif - -import CmdLineOpts ( opt_Static, opt_DoTickyProfiling ) -import CStrings ( pp_cSEP ) -import DataCon ( ConTag ) -import Module ( moduleName, moduleNameFS, - Module, isHomeModule ) -import Name ( Name, getName, isDllName, isExternalName ) -import TyCon ( TyCon ) -import Unique ( pprUnique, Unique ) -import PrimOp ( PrimOp ) -import CostCentre ( CostCentre, CostCentreStack ) -import Outputable -import FastString -\end{code} - -things we want to find out: - -* should the labelled things be declared "static" (visible only in this file)? - -* should it be declared "const" (read-only text space)? - -* does it need declarations at all? (v common Prelude things are pre-declared) - -* what type does it have? (for generating accurate enough C declarations - so that the C compiler won't complain). - -\begin{code} -data CLabel - = IdLabel -- A family of labels related to the - Name -- definition of a particular Id - IdLabelInfo - - | DataConLabel -- Ditto data constructors - Name - DataConLabelInfo - - | CaseLabel -- A family of labels related to a particular case expression - Unique -- Unique says which case expression - CaseLabelInfo - - | TyConLabel TyCon -- currently only one kind of TyconLabel, - -- a 'Closure Table'. - - | AsmTempLabel Unique - - | ModuleInitLabel - Module -- the module name - String -- its "way" - -- at some point we might want some kind of version number in - -- the module init label, to guard against compiling modules in - -- the wrong order. We can't use the interface file version however, - -- because we don't always recompile modules which depend on a module - -- whose version has changed. - - | PlainModuleInitLabel Module -- without the vesrion & way info - - | RtsLabel RtsLabelInfo - - | ForeignLabel FastString Bool -- a 'C' (or otherwise foreign) label - -- Bool <=> is dynamic - - | CC_Label CostCentre - | CCS_Label CostCentreStack - - deriving (Eq, Ord) -\end{code} - -\begin{code} -data IdLabelInfo - = Closure -- Label for (static???) closure - | SRT -- Static reference table - | SRTDesc -- Static reference table descriptor - | InfoTbl -- Info tables for closures; always read-only - | Entry -- entry point - | Slow -- slow entry point - - -- Ticky-ticky counting - | RednCounts -- Label of place to keep reduction-count info for - -- this Id - - | Bitmap -- A bitmap (function or case return) - - deriving (Eq, Ord) - -data DataConLabelInfo - = ConEntry -- the only kind of entry pt for constructors - | ConInfoTbl -- corresponding info table - | StaticConEntry -- static constructor entry point - | StaticInfoTbl -- corresponding info table - deriving (Eq, Ord) - -data CaseLabelInfo - = CaseReturnPt - | CaseReturnInfo - | CaseVecTbl - | CaseAlt ConTag - | CaseDefault - deriving (Eq, Ord) - -data RtsLabelInfo - = RtsShouldNeverHappenCode - - | RtsBlackHoleInfoTbl LitString -- black hole with info table name - - | RtsUpdInfo -- upd_frame_info - | RtsSeqInfo -- seq_frame_info - | RtsGCEntryLabel String -- a heap check fail handler, eg stg_chk_2 - | RtsMainCapability -- MainCapability - | Rts_Closure String -- misc rts closures, eg CHARLIKE_closure - | Rts_Info String -- misc rts itbls, eg MUT_ARR_PTRS_FROZEN_info - | Rts_Code String -- misc rts code - - | RtsSelectorInfoTbl Bool{-updatable-} Int{-offset-} -- Selector thunks - | RtsSelectorEntry Bool{-updatable-} Int{-offset-} - - | RtsApInfoTbl Bool{-updatable-} Int{-arity-} -- AP thunks - | RtsApEntry Bool{-updatable-} Int{-arity-} - - | RtsPrimOp PrimOp - - | RtsTopTickyCtr - - | RtsModuleRegd - - | RtsApplyInfoLabel LitString - | RtsApplyEntryLabel LitString - - deriving (Eq, Ord) - --- Label Type: for generating C declarations. - -data CLabelType - = RetInfoTblType - | InfoTblType - | ClosureType - | VecTblType - | ClosureTblType - | CodeType - | DataType -\end{code} - -\begin{code} -mkClosureLabel id = IdLabel id Closure -mkSRTLabel id = IdLabel id SRT -mkSRTDescLabel id = IdLabel id SRTDesc -mkInfoTableLabel id = IdLabel id InfoTbl -mkEntryLabel id = IdLabel id Entry -mkSlowEntryLabel id = IdLabel id Slow -mkBitmapLabel id = IdLabel id Bitmap -mkRednCountsLabel id = IdLabel id RednCounts - -mkStaticInfoTableLabel con = DataConLabel con StaticInfoTbl -mkConInfoTableLabel con = DataConLabel con ConInfoTbl -mkConEntryLabel con = DataConLabel con ConEntry -mkStaticConEntryLabel con = DataConLabel con StaticConEntry - - -mkReturnPtLabel uniq = CaseLabel uniq CaseReturnPt -mkReturnInfoLabel uniq = CaseLabel uniq CaseReturnInfo -mkVecTblLabel uniq = CaseLabel uniq CaseVecTbl -mkAltLabel uniq tag = CaseLabel uniq (CaseAlt tag) -mkDefaultLabel uniq = CaseLabel uniq CaseDefault - - -mkClosureTblLabel tycon = TyConLabel tycon - -mkAsmTempLabel = AsmTempLabel - -mkModuleInitLabel = ModuleInitLabel -mkPlainModuleInitLabel = PlainModuleInitLabel - - -- Some fixed runtime system labels - -mkErrorStdEntryLabel = RtsLabel RtsShouldNeverHappenCode -mkStgUpdatePAPLabel = RtsLabel (Rts_Code "stg_update_PAP") -mkSplitMarkerLabel = RtsLabel (Rts_Code "__stg_split_marker") -mkUpdInfoLabel = RtsLabel RtsUpdInfo -mkSeqInfoLabel = RtsLabel RtsSeqInfo -mkIndInfoLabel = RtsLabel (Rts_Info "stg_IND_info") -mkIndStaticInfoLabel = RtsLabel (Rts_Info "stg_IND_STATIC_info") -mkRtsGCEntryLabel str = RtsLabel (RtsGCEntryLabel str) -mkMainCapabilityLabel = RtsLabel RtsMainCapability -mkCharlikeClosureLabel = RtsLabel (Rts_Closure "stg_CHARLIKE_closure") -mkIntlikeClosureLabel = RtsLabel (Rts_Closure "stg_INTLIKE_closure") -mkMAP_FROZEN_infoLabel = RtsLabel (Rts_Info "stg_MUT_ARR_PTRS_FROZEN_info") -mkEMPTY_MVAR_infoLabel = RtsLabel (Rts_Info "stg_EMPTY_MVAR_info") - -mkTopTickyCtrLabel = RtsLabel RtsTopTickyCtr -mkBlackHoleInfoTableLabel = RtsLabel (RtsBlackHoleInfoTbl SLIT("stg_BLACKHOLE_info")) -mkBlackHoleBQInfoTableLabel = RtsLabel (RtsBlackHoleInfoTbl SLIT("stg_BLACKHOLE_BQ_info")) -mkCAFBlackHoleInfoTableLabel = RtsLabel (RtsBlackHoleInfoTbl SLIT("stg_CAF_BLACKHOLE_info")) -mkSECAFBlackHoleInfoTableLabel = if opt_DoTickyProfiling then - RtsLabel (RtsBlackHoleInfoTbl SLIT("stg_SE_CAF_BLACKHOLE_info")) - else -- RTS won't have info table unless -ticky is on - panic "mkSECAFBlackHoleInfoTableLabel requires -ticky" -mkRtsPrimOpLabel primop = RtsLabel (RtsPrimOp primop) - -moduleRegdLabel = RtsLabel RtsModuleRegd - -mkSelectorInfoLabel upd off = RtsLabel (RtsSelectorInfoTbl upd off) -mkSelectorEntryLabel upd off = RtsLabel (RtsSelectorEntry upd off) - -mkApInfoTableLabel upd off = RtsLabel (RtsApInfoTbl upd off) -mkApEntryLabel upd off = RtsLabel (RtsApEntry upd off) - - -- Foreign labels - -mkForeignLabel :: FastString -> Bool -> CLabel -mkForeignLabel str is_dynamic = ForeignLabel str is_dynamic - - -- Cost centres etc. - -mkCC_Label cc = CC_Label cc -mkCCS_Label ccs = CCS_Label ccs - --- Std RTS application routines - -mkRtsApplyInfoLabel = RtsLabel . RtsApplyInfoLabel -mkRtsApplyEntryLabel = RtsLabel . RtsApplyEntryLabel -\end{code} - -\begin{code} -needsCDecl :: CLabel -> Bool -- False <=> it's pre-declared; don't bother -isAsmTemp :: CLabel -> Bool -- is a local temporary for native code generation -externallyVisibleCLabel :: CLabel -> Bool -- not C "static" -\end{code} - -@needsCDecl@ is @True@ unless the thing is a deeply-@PreludeCore@-ish -object. {\em Also:} No need to spit out labels for things generated -by the flattener (in @AbsCUtils@)---it is careful to ensure references -to them are always backwards. These are return-point and vector-table -labels. - -Declarations for (non-prelude) @Id@-based things are needed because of -mutual recursion. - -Declarations for direct return points are needed, because they may be -let-no-escapes, which can be recursive. - -\begin{code} - -- don't bother declaring SRT & Bitmap labels, we always make sure - -- they are defined before use. -needsCDecl (IdLabel _ SRT) = False -needsCDecl (IdLabel _ SRTDesc) = False -needsCDecl (IdLabel _ Bitmap) = False -needsCDecl (IdLabel _ _) = True -needsCDecl (CaseLabel _ CaseReturnPt) = True -needsCDecl (DataConLabel _ _) = True -needsCDecl (TyConLabel _) = True -needsCDecl (ModuleInitLabel _ _) = True -needsCDecl (PlainModuleInitLabel _) = True - -needsCDecl (CaseLabel _ _) = False -needsCDecl (AsmTempLabel _) = False -needsCDecl (RtsLabel _) = False -needsCDecl (ForeignLabel _ _) = False -needsCDecl (CC_Label _) = False -needsCDecl (CCS_Label _) = False -\end{code} - -Whether the label is an assembler temporary: - -\begin{code} -isAsmTemp (AsmTempLabel _) = True -isAsmTemp _ = False -\end{code} - -C ``static'' or not... -From the point of view of the code generator, a name is -externally visible if it has to be declared as exported -in the .o file's symbol table; that is, made non-static. - -\begin{code} -externallyVisibleCLabel (DataConLabel _ _) = True -externallyVisibleCLabel (TyConLabel tc) = True -externallyVisibleCLabel (CaseLabel _ _) = False -externallyVisibleCLabel (AsmTempLabel _) = False -externallyVisibleCLabel (ModuleInitLabel _ _)= True -externallyVisibleCLabel (PlainModuleInitLabel _)= True -externallyVisibleCLabel (RtsLabel RtsModuleRegd) = False --hack -externallyVisibleCLabel (RtsLabel _) = True -externallyVisibleCLabel (ForeignLabel _ _) = True -externallyVisibleCLabel (IdLabel id _) = isExternalName id -externallyVisibleCLabel (CC_Label _) = False -- not strictly true -externallyVisibleCLabel (CCS_Label _) = False -- not strictly true -\end{code} - -For generating correct types in label declarations, and also for -deciding whether the C compiler would like us to use '&' before the -label to get its address: - -\begin{code} -labelType :: CLabel -> CLabelType -labelType (RtsLabel (RtsBlackHoleInfoTbl _)) = InfoTblType -labelType (RtsLabel (RtsSelectorInfoTbl _ _)) = InfoTblType -labelType (RtsLabel (RtsApInfoTbl _ _)) = InfoTblType -labelType (RtsLabel RtsUpdInfo) = RetInfoTblType -labelType (RtsLabel RtsSeqInfo) = RetInfoTblType -labelType (RtsLabel RtsTopTickyCtr) = CodeType -- XXX -labelType (RtsLabel (Rts_Info _)) = InfoTblType -labelType (RtsLabel (RtsApplyInfoLabel _)) = RetInfoTblType -labelType (RtsLabel (RtsApplyEntryLabel _)) = CodeType -labelType (CaseLabel _ CaseReturnInfo) = RetInfoTblType -labelType (CaseLabel _ CaseReturnPt) = CodeType -labelType (CaseLabel _ CaseVecTbl) = VecTblType -labelType (TyConLabel _) = ClosureTblType -labelType (ModuleInitLabel _ _) = CodeType -labelType (PlainModuleInitLabel _) = CodeType -labelType (CC_Label _) = CodeType -- hack -labelType (CCS_Label _) = CodeType -- hack - -labelType (IdLabel _ info) = - case info of - InfoTbl -> InfoTblType - Closure -> ClosureType - Bitmap -> DataType - _ -> CodeType - -labelType (DataConLabel _ info) = - case info of - ConInfoTbl -> InfoTblType - StaticInfoTbl -> InfoTblType - _ -> CodeType - -labelType _ = DataType -\end{code} - -When referring to data in code, we need to know whether -that data resides in a DLL or not. [Win32 only.] -@labelDynamic@ returns @True@ if the label is located -in a DLL, be it a data reference or not. - -\begin{code} -labelDynamic :: CLabel -> Bool -labelDynamic lbl = - case lbl of - -- The special case for RtsShouldNeverHappenCode is because the associated address is - -- NULL, i.e. not a DLL entry point - RtsLabel RtsShouldNeverHappenCode -> False - RtsLabel _ -> not opt_Static -- i.e., is the RTS in a DLL or not? - IdLabel n k -> isDllName n - DataConLabel n k -> isDllName n - TyConLabel tc -> isDllName (getName tc) - ForeignLabel _ d -> d - ModuleInitLabel m _ -> (not opt_Static) && (not (isHomeModule m)) - PlainModuleInitLabel m -> (not opt_Static) && (not (isHomeModule m)) - _ -> False -\end{code} - - -OLD?: These GRAN functions are needed for spitting out GRAN_FETCH() at the -right places. It is used to detect when the abstractC statement of an -CCodeBlock actually contains the code for a slow entry point. -- HWL - -We need at least @Eq@ for @CLabels@, because we want to avoid -duplicate declarations in generating C (see @labelSeenTE@ in -@PprAbsC@). - ------------------------------------------------------------------------------ -Printing out CLabels. - -Convention: - - _ - -where is _ for external names and for -internal names. is one of the following: - - info Info table - srt Static reference table - srtd Static reference table descriptor - entry Entry code - slow Slow entry code (if any) - ret Direct return address - vtbl Vector table - _alt Case alternative (tag n) - dflt Default case alternative - btm Large bitmap vector - closure Static closure - con_entry Dynamic Constructor entry code - con_info Dynamic Constructor info table - static_entry Static Constructor entry code - static_info Static Constructor info table - sel_info Selector info table - sel_entry Selector entry code - cc Cost centre - ccs Cost centre stack - -\begin{code} -pprCLabel :: CLabel -> SDoc - -#if ! OMIT_NATIVE_CODEGEN -pprCLabel (AsmTempLabel u) - = text (fmtAsmLbl (show u)) -#endif - -pprCLabel lbl = -#if ! OMIT_NATIVE_CODEGEN - getPprStyle $ \ sty -> - if asmStyle sty && underscorePrefix then - pp_cSEP <> pprCLbl lbl - else -#endif - pprCLbl lbl - -pprCLbl (CaseLabel u CaseReturnPt) - = hcat [pprUnique u, pp_cSEP, ptext SLIT("ret")] -pprCLbl (CaseLabel u CaseReturnInfo) - = hcat [pprUnique u, pp_cSEP, ptext SLIT("info")] -pprCLbl (CaseLabel u CaseVecTbl) - = hcat [pprUnique u, pp_cSEP, ptext SLIT("vtbl")] -pprCLbl (CaseLabel u (CaseAlt tag)) - = hcat [pprUnique u, pp_cSEP, int tag, pp_cSEP, ptext SLIT("alt")] -pprCLbl (CaseLabel u CaseDefault) - = hcat [pprUnique u, pp_cSEP, ptext SLIT("dflt")] - -pprCLbl (RtsLabel RtsShouldNeverHappenCode) = ptext SLIT("NULL") --- used to be stg_error_entry but Windows can't have DLL entry points as static --- initialisers, and besides, this ShouldNeverHappen, right? - -pprCLbl (RtsLabel RtsUpdInfo) = ptext SLIT("stg_upd_frame_info") -pprCLbl (RtsLabel RtsSeqInfo) = ptext SLIT("stg_seq_frame_info") -pprCLbl (RtsLabel RtsMainCapability) = ptext SLIT("MainCapability") -pprCLbl (RtsLabel (RtsGCEntryLabel str)) = text str -pprCLbl (RtsLabel (Rts_Closure str)) = text str -pprCLbl (RtsLabel (Rts_Info str)) = text str -pprCLbl (RtsLabel (Rts_Code str)) = text str - -pprCLbl (RtsLabel RtsTopTickyCtr) = ptext SLIT("top_ct") - -pprCLbl (RtsLabel (RtsBlackHoleInfoTbl info)) = ptext info - -pprCLbl (RtsLabel (RtsSelectorInfoTbl upd_reqd offset)) - = hcat [ptext SLIT("stg_sel_"), text (show offset), - ptext (if upd_reqd - then SLIT("_upd_info") - else SLIT("_noupd_info")) - ] - -pprCLbl (RtsLabel (RtsSelectorEntry upd_reqd offset)) - = hcat [ptext SLIT("stg_sel_"), text (show offset), - ptext (if upd_reqd - then SLIT("_upd_entry") - else SLIT("_noupd_entry")) - ] - -pprCLbl (RtsLabel (RtsApInfoTbl upd_reqd arity)) - = hcat [ptext SLIT("stg_ap_"), text (show arity), - ptext (if upd_reqd - then SLIT("_upd_info") - else SLIT("_noupd_info")) - ] - -pprCLbl (RtsLabel (RtsApEntry upd_reqd arity)) - = hcat [ptext SLIT("stg_ap_"), text (show arity), - ptext (if upd_reqd - then SLIT("_upd_entry") - else SLIT("_noupd_entry")) - ] - -pprCLbl (RtsLabel (RtsApplyInfoLabel fs)) - = ptext SLIT("stg_ap_") <> ptext fs <> ptext SLIT("_info") - -pprCLbl (RtsLabel (RtsApplyEntryLabel fs)) - = ptext SLIT("stg_ap_") <> ptext fs <> ptext SLIT("_ret") - -pprCLbl (RtsLabel (RtsPrimOp primop)) - = ppr primop <> ptext SLIT("_fast") - -pprCLbl (RtsLabel RtsModuleRegd) - = ptext SLIT("module_registered") - -pprCLbl (ForeignLabel str _) - = ftext str - -pprCLbl (TyConLabel tc) - = hcat [ppr tc, pp_cSEP, ptext SLIT("closure_tbl")] - -pprCLbl (IdLabel id flavor) = ppr id <> ppIdFlavor flavor -pprCLbl (DataConLabel con flavor) = ppr con <> ppConFlavor flavor - -pprCLbl (CC_Label cc) = ppr cc -pprCLbl (CCS_Label ccs) = ppr ccs - -pprCLbl (ModuleInitLabel mod way) - = ptext SLIT("__stginit_") <> ftext (moduleNameFS (moduleName mod)) - <> char '_' <> text way -pprCLbl (PlainModuleInitLabel mod) - = ptext SLIT("__stginit_") <> ftext (moduleNameFS (moduleName mod)) - -ppIdFlavor :: IdLabelInfo -> SDoc - -ppIdFlavor x = pp_cSEP <> - (case x of - Closure -> ptext SLIT("closure") - SRT -> ptext SLIT("srt") - SRTDesc -> ptext SLIT("srtd") - InfoTbl -> ptext SLIT("info") - Entry -> ptext SLIT("entry") - Slow -> ptext SLIT("slow") - RednCounts -> ptext SLIT("ct") - Bitmap -> ptext SLIT("btm") - ) - -ppConFlavor x = pp_cSEP <> - (case x of - ConEntry -> ptext SLIT("con_entry") - ConInfoTbl -> ptext SLIT("con_info") - StaticConEntry -> ptext SLIT("static_entry") - StaticInfoTbl -> ptext SLIT("static_info") - ) -\end{code} diff --git a/ghc/compiler/absCSyn/CStrings.lhs b/ghc/compiler/absCSyn/CStrings.lhs deleted file mode 100644 index f25e6c204f..0000000000 --- a/ghc/compiler/absCSyn/CStrings.lhs +++ /dev/null @@ -1,55 +0,0 @@ -This module deals with printing C string literals - -\begin{code} -module CStrings( - CLabelString, isCLabelString, pprCLabelString, - - pp_cSEP, - - pprFSInCStyle, pprStringInCStyle - ) where - -#include "HsVersions.h" - -import Char ( ord, chr, isAlphaNum ) -import FastString -import Outputable -\end{code} - - -\begin{code} -type CLabelString = FastString -- A C label, completely unencoded - -pprCLabelString :: CLabelString -> SDoc -pprCLabelString lbl = ftext lbl - -isCLabelString :: CLabelString -> Bool -- Checks to see if this is a valid C label -isCLabelString lbl - = all ok (unpackFS lbl) - where - ok c = isAlphaNum c || c == '_' || c == '.' - -- The '.' appears in e.g. "foo.so" in the - -- module part of a ExtName. Maybe it should be separate - -pp_cSEP = char '_' -\end{code} - -\begin{code} -pprFSInCStyle :: FastString -> SDoc --- Assumes it contains only characters '\0'..'\xFF'! -pprFSInCStyle fs = pprStringInCStyle (unpackFS fs) - -pprStringInCStyle :: String -> SDoc -pprStringInCStyle s = doubleQuotes (text (concatMap charToC s)) - -charToC :: Char -> String -charToC '\"' = "\\\"" -charToC '\'' = "\\\'" -charToC '\\' = "\\\\" -charToC c | c >= ' ' && c <= '~' = [c] - | c > '\xFF' = panic ("charToC "++show c) - | otherwise = ['\\', - chr (ord '0' + ord c `div` 64), - chr (ord '0' + ord c `div` 8 `mod` 8), - chr (ord '0' + ord c `mod` 8)] -\end{code} diff --git a/ghc/compiler/absCSyn/Costs.lhs b/ghc/compiler/absCSyn/Costs.lhs deleted file mode 100644 index 17ea6d57f4..0000000000 --- a/ghc/compiler/absCSyn/Costs.lhs +++ /dev/null @@ -1,421 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% -% $Id: Costs.lhs,v 1.33 2003/07/28 16:05:30 simonmar Exp $ -% -% Only needed in a GranSim setup -- HWL -% --------------------------------------------------------------------------- - -\section[Costs]{Evaluating the costs of computing some abstract C code} - -This module provides all necessary functions for computing for a given -abstract~C Program the costs of executing that program. This is done by the -exported function: - -\begin{quote} - {\verb type CostRes = (Int, Int, Int, Int, Int)} - {\verb costs :: AbstractC -> CostRes } -\end{quote} - -The meaning of the result tuple is: -\begin{itemize} - \item The first component ({\tt i}) counts the number of integer, - arithmetic and bit-manipulating instructions. - \item The second component ({\tt b}) counts the number of branches (direct - branches as well as indirect ones). - \item The third component ({\tt l}) counts the number of load instructions. - \item The fourth component ({\tt s}) counts the number of store - instructions. - \item The fifth component ({\tt f}) counts the number of floating point - instructions. -\end{itemize} - -This function is needed in GranSim for costing pieces of abstract C. - -These are first suggestions for scaling the costs. But, this scaling should -be done in the RTS rather than the compiler (this really should be -tunable!): - -\begin{pseudocode} - -#define LOAD_COSTS 2 -#define STORE_COSTS 2 -#define INT_ARITHM_COSTS 1 -#define GMP_ARITHM_COSTS 3 {- any clue for GMP costs ? -} -#define FLOAT_ARITHM_COSTS 3 {- any clue for float costs ? -} -#define BRANCH_COSTS 2 - -\end{pseudocode} - -\begin{code} -#define ACCUM_COSTS(i,b,l,s,f) (i+b+l+s+f) - -#define NUM_REGS 10 {- PprAbsCSyn.lhs -} {- runtime/c-as-asm/CallWrap_C.lc -} -#define RESTORE_COSTS (Cost (0, 0, NUM_REGS, 0, 0) :: CostRes) -#define SAVE_COSTS (Cost (0, 0, 0, NUM_REGS, 0) :: CostRes) -#define CCALL_COSTS_GUESS (Cost (50, 0, 0, 0, 0) :: CostRes) - -module Costs( costs, - addrModeCosts, CostRes(Cost), nullCosts, Side(..) - ) where - -#include "HsVersions.h" - -import AbsCSyn -import StgSyn ( StgOp(..) ) -import PrimOp ( primOpNeedsWrapper, PrimOp(..) ) -import Panic ( trace ) - --- -------------------------------------------------------------------------- -data CostRes = Cost (Int, Int, Int, Int, Int) - deriving (Show) - -nullCosts = Cost (0, 0, 0, 0, 0) :: CostRes -initHdrCosts = Cost (2, 0, 0, 1, 0) :: CostRes - -instance Eq CostRes where - (==) t1 t2 = i && b && l && s && f - where (i,b,l,s,f) = binOp' (==) t1 t2 - -instance Num CostRes where - (+) = binOp (+) - (-) = binOp (-) - (*) = binOp (*) - negate = mapOp negate - abs = mapOp abs - signum = mapOp signum - fromInteger _ = error "fromInteger not defined" - -mapOp :: (Int -> Int) -> CostRes -> CostRes -mapOp g ( Cost (i, b, l, s, f) ) = Cost (g i, g b, g l, g s, g f) - -binOp :: (Int -> Int -> Int) -> CostRes -> CostRes -> CostRes -binOp o ( Cost (i1, b1, l1, s1, f1) ) ( Cost (i2, b2, l2, s2, f2) ) = - ( Cost (i1 `o` i2, b1 `o` b2, l1 `o` l2, s1 `o` s2, f1 `o` f2) ) - -binOp' :: (Int -> Int -> a) -> CostRes -> CostRes -> (a,a,a,a,a) -binOp' o ( Cost (i1, b1, l1, s1, f1) ) ( Cost (i2, b2, l2, s2, f2) ) = - (i1 `o` i2, b1 `o` b2, l1 `o` l2, s1 `o` s2, f1 `o` f2) - --- -------------------------------------------------------------------------- - -data Side = Lhs | Rhs - deriving (Eq) - --- -------------------------------------------------------------------------- - -costs :: AbstractC -> CostRes - -costs absC = - case absC of - AbsCNop -> nullCosts - - AbsCStmts absC1 absC2 -> costs absC1 + costs absC2 - - CAssign (CReg _) (CReg _) -> Cost (1,0,0,0,0) -- typ.: mov %reg1,%reg2 - - CAssign (CReg _) (CTemp _ _) -> Cost (1,0,0,0,0) - - CAssign (CReg _) source_m -> addrModeCosts source_m Rhs - - CAssign target_m source_m -> addrModeCosts target_m Lhs + - addrModeCosts source_m Rhs - - CJump (CLbl _ _) -> Cost (0,1,0,0,0) -- no ld for call necessary - - CJump mode -> addrModeCosts mode Rhs + - Cost (0,1,0,0,0) - - CFallThrough mode -> addrModeCosts mode Rhs + -- chu' 0.24 - Cost (0,1,0,0,0) - - CReturn mode info -> case info of - DirectReturn -> addrModeCosts mode Rhs + - Cost (0,1,0,0,0) - - -- i.e. ld address to reg and call reg - - DynamicVectoredReturn mode' -> - addrModeCosts mode Rhs + - addrModeCosts mode' Rhs + - Cost (0,1,1,0,0) - - {- generates code like this: - JMP_()[RVREL()]; - i.e. 1 possb ld for mode' - 1 ld for RVREL - 1 possb ld for mode - 1 call -} - - StaticVectoredReturn _ -> addrModeCosts mode Rhs + - Cost (0,1,1,0,0) - - -- as above with mode' fixed to CLit - -- typically 2 ld + 1 call; 1st ld due - -- to CVal as mode - - CSwitch mode alts absC -> nullCosts - {- for handling costs of all branches of - a CSwitch see PprAbsC. - Basically: - Costs for branch = - Costs before CSwitch + - addrModeCosts of head + - Costs for 1 cond branch + - Costs for body of branch - -} - - CCodeBlock _ absC -> costs absC - - CInitHdr cl_info reg_rel cost_centre _ -> initHdrCosts - - {- This is more fancy but superflous: The addr modes - are fixed and so the costs are const! - - argCosts + initHdrCosts - where argCosts = addrModeCosts (CAddr reg_rel) Rhs + - addrModeCosts base_lbl + -- CLbl! - 3*addrModeCosts (mkIntCLit 1{- any val -}) - -} - {- this extends to something like - SET_SPEC_HDR(...) - For costing the args of this macro - see PprAbsC.lhs where args are inserted -} - - COpStmt modes_res op modes_args _ -> - {- - let - n = length modes_res - in - (0, 0, n, n, 0) + - primOpCosts primOp + - if primOpNeedsWrapper primOp then SAVE_COSTS + RESTORE_COSTS - else nullCosts - -- ^^HWL - -} - foldl (+) nullCosts [addrModeCosts mode Lhs | mode <- modes_res] + - foldl (+) nullCosts [addrModeCosts mode Rhs | mode <- modes_args] + - opCosts op - - CSimultaneous absC -> costs absC - - CCheck _ amodes code -> Cost (2, 1, 0, 0, 0) -- ToDo: refine this by - -- looking at the first arg - - CRetDirect _ _ _ _ -> nullCosts - - CMacroStmt macro modes -> stmtMacroCosts macro modes - - CCallProfCtrMacro _ _ -> nullCosts - {- we don't count profiling in GrAnSim -} - - CCallProfCCMacro _ _ -> nullCosts - {- we don't count profiling in GrAnSim -} - - -- *** the next three [or so...] are DATA (those above are CODE) *** - -- as they are data rather than code they all have nullCosts -- HWL - - CCallTypedef _ _ _ _ _ -> nullCosts - - CStaticClosure _ _ _ _ -> nullCosts - - CSRT _ _ -> nullCosts - - CBitmap _ -> nullCosts - - CClosureInfoAndCode _ _ -> nullCosts - - CRetVector _ _ _ _ -> nullCosts - - CClosureTbl _ -> nullCosts - - CCostCentreDecl _ _ -> nullCosts - - CCostCentreStackDecl _ -> nullCosts - - CSplitMarker -> nullCosts - - _ -> trace ("Costs.costs") nullCosts - - --- --------------------------------------------------------------------------- - -addrModeCosts :: CAddrMode -> Side -> CostRes - --- addrModeCosts _ _ = nullCosts - -addrModeCosts addr_mode side = - let - lhs = side == Lhs - in - case addr_mode of - CVal _ _ -> if lhs then Cost (0, 0, 0, 1, 0) - else Cost (0, 0, 1, 0, 0) - - CAddr (CIndex _ n _ ) -> Cost (1, 0, 1, 0, 0) -- does pointer arithmetic - - CAddr _ -> nullCosts - - CReg _ -> nullCosts {- loading from, storing to reg is free ! -} - {- for costing CReg->Creg ops see special -} - {- case in costs fct -} - - CTemp _ _ -> nullCosts {- if lhs then Cost (0, 0, 0, 1, 0) - else Cost (0, 0, 1, 0, 0) -} - -- ``Temporaries'' correspond to local variables in C, and registers in - -- native code. - -- I assume they can be somewhat optimized by gcc -- HWL - - CLbl _ _ -> if lhs then Cost (0, 0, 0, 1, 0) - else Cost (2, 0, 0, 0, 0) - -- Rhs: typically: sethi %hi(lbl),%tmp_reg - -- or %tmp_reg,%lo(lbl),%target_reg - - -- Check the following 3 (checked form CLit on) - - CCharLike mode -> if lhs then Cost (0, 0, 0, 1, 0) - else Cost (0, 0, 1, 0, 0) - - CIntLike mode -> if lhs then Cost (0, 0, 0, 1, 0) - else Cost (0, 0, 1, 0, 0) - - CLit _ -> if lhs then nullCosts -- should never occur - else Cost (1, 0, 0, 0, 0) -- typ.: mov lit,%reg - - CJoinPoint _ -> if lhs then Cost (0, 0, 0, 1, 0) - else Cost (0, 0, 1, 0, 0) - - CMacroExpr _ macro mode_list -> exprMacroCosts side macro mode_list - --- --------------------------------------------------------------------------- - -exprMacroCosts :: Side -> CExprMacro -> [CAddrMode] -> CostRes - -exprMacroCosts side macro mode_list = - let - arg_costs = foldl (+) nullCosts - (map (\ x -> addrModeCosts x Rhs) mode_list) - in - arg_costs + - case macro of - ENTRY_CODE -> nullCosts -- nothing - ARG_TAG -> nullCosts -- nothing - GET_TAG -> Cost (0, 0, 1, 0, 0) -- indirect load - --- --------------------------------------------------------------------------- - -stmtMacroCosts :: CStmtMacro -> [CAddrMode] -> CostRes - -stmtMacroCosts macro modes = - case macro of - UPD_CAF -> Cost (7, 0, 1, 3, 0) {- SMupdate.lh -} - UPD_BH_UPDATABLE -> Cost (3, 0, 0, 1, 0) {- SMupdate.lh -} - UPD_BH_SINGLE_ENTRY -> Cost (3, 0, 0, 1, 0) {- SMupdate.lh -} - PUSH_UPD_FRAME -> Cost (3, 0, 0, 4, 0) {- Updates.h -} - SET_TAG -> nullCosts {- COptRegs.lh -} - GRAN_FETCH -> nullCosts {- GrAnSim bookkeeping -} - GRAN_RESCHEDULE -> nullCosts {- GrAnSim bookkeeping -} - GRAN_FETCH_AND_RESCHEDULE -> nullCosts {- GrAnSim bookkeeping -} - GRAN_YIELD -> nullCosts {- GrAnSim bookkeeping -- added SOF -} - THREAD_CONTEXT_SWITCH -> nullCosts {- GrAnSim bookkeeping -} - _ -> trace ("Costs.stmtMacroCosts") nullCosts - --- --------------------------------------------------------------------------- - -floatOps :: [PrimOp] -floatOps = - [ FloatGtOp , FloatGeOp , FloatEqOp , FloatNeOp , FloatLtOp , FloatLeOp - , DoubleGtOp , DoubleGeOp , DoubleEqOp , DoubleNeOp , DoubleLtOp , DoubleLeOp - , FloatAddOp , FloatSubOp , FloatMulOp , FloatDivOp , FloatNegOp - , Float2IntOp , Int2FloatOp - , FloatExpOp , FloatLogOp , FloatSqrtOp - , FloatSinOp , FloatCosOp , FloatTanOp - , FloatAsinOp , FloatAcosOp , FloatAtanOp - , FloatSinhOp , FloatCoshOp , FloatTanhOp - , FloatPowerOp - , DoubleAddOp , DoubleSubOp , DoubleMulOp , DoubleDivOp , DoubleNegOp - , Double2IntOp , Int2DoubleOp - , Double2FloatOp , Float2DoubleOp - , DoubleExpOp , DoubleLogOp , DoubleSqrtOp - , DoubleSinOp , DoubleCosOp , DoubleTanOp - , DoubleAsinOp , DoubleAcosOp , DoubleAtanOp - , DoubleSinhOp , DoubleCoshOp , DoubleTanhOp - , DoublePowerOp - , FloatDecodeOp - , DoubleDecodeOp - ] - -gmpOps :: [PrimOp] -gmpOps = - [ IntegerAddOp , IntegerSubOp , IntegerMulOp - , IntegerQuotRemOp , IntegerDivModOp - , IntegerCmpOp - , Integer2IntOp , Int2IntegerOp - ] - - -umul_costs = Cost (21,4,0,0,0) -- due to spy counts -rem_costs = Cost (30,15,0,0,0) -- due to spy counts -div_costs = Cost (30,15,0,0,0) -- due to spy counts - - - --- --------------------------------------------------------------------------- - -opCosts :: StgOp -> CostRes - -opCosts (StgFCallOp _ _) = SAVE_COSTS + RESTORE_COSTS - -- Don't guess costs of ccall proper - -- for exact costing use a GRAN_EXEC in the C code - -opCosts (StgPrimOp primop) - = primOpCosts primop + - if primOpNeedsWrapper primop then SAVE_COSTS + RESTORE_COSTS - else nullCosts - -primOpCosts :: PrimOp -> CostRes - --- Usually 3 mov instructions are needed to get args and res in right place. -primOpCosts IntMulOp = Cost (3, 1, 0, 0, 0) + umul_costs -primOpCosts IntQuotOp = Cost (3, 1, 0, 0, 0) + div_costs -primOpCosts IntRemOp = Cost (3, 1, 0, 0, 0) + rem_costs -primOpCosts IntNegOp = Cost (1, 1, 0, 0, 0) -- translates into 1 sub - -primOpCosts FloatGtOp = Cost (2, 0, 0, 0, 2) -- expensive f-comp -primOpCosts FloatGeOp = Cost (2, 0, 0, 0, 2) -- expensive f-comp -primOpCosts FloatEqOp = Cost (0, 0, 0, 0, 2) -- cheap f-comp -primOpCosts FloatNeOp = Cost (0, 0, 0, 0, 2) -- cheap f-comp -primOpCosts FloatLtOp = Cost (2, 0, 0, 0, 2) -- expensive f-comp -primOpCosts FloatLeOp = Cost (2, 0, 0, 0, 2) -- expensive f-comp -primOpCosts DoubleGtOp = Cost (2, 0, 0, 0, 2) -- expensive f-comp -primOpCosts DoubleGeOp = Cost (2, 0, 0, 0, 2) -- expensive f-comp -primOpCosts DoubleEqOp = Cost (0, 0, 0, 0, 2) -- cheap f-comp -primOpCosts DoubleNeOp = Cost (0, 0, 0, 0, 2) -- cheap f-comp -primOpCosts DoubleLtOp = Cost (2, 0, 0, 0, 2) -- expensive f-comp -primOpCosts DoubleLeOp = Cost (2, 0, 0, 0, 2) -- expensive f-comp - -primOpCosts FloatExpOp = Cost (2, 1, 4, 4, 3) -primOpCosts FloatLogOp = Cost (2, 1, 4, 4, 3) -primOpCosts FloatSqrtOp = Cost (2, 1, 4, 4, 3) -primOpCosts FloatSinOp = Cost (2, 1, 4, 4, 3) -primOpCosts FloatCosOp = Cost (2, 1, 4, 4, 3) -primOpCosts FloatTanOp = Cost (2, 1, 4, 4, 3) -primOpCosts FloatAsinOp = Cost (2, 1, 4, 4, 3) -primOpCosts FloatAcosOp = Cost (2, 1, 4, 4, 3) -primOpCosts FloatAtanOp = Cost (2, 1, 4, 4, 3) -primOpCosts FloatSinhOp = Cost (2, 1, 4, 4, 3) -primOpCosts FloatCoshOp = Cost (2, 1, 4, 4, 3) -primOpCosts FloatTanhOp = Cost (2, 1, 4, 4, 3) ---primOpCosts FloatAsinhOp = Cost (2, 1, 4, 4, 3) ---primOpCosts FloatAcoshOp = Cost (2, 1, 4, 4, 3) ---primOpCosts FloatAtanhOp = Cost (2, 1, 4, 4, 3) -primOpCosts FloatPowerOp = Cost (2, 1, 4, 4, 3) - -{- There should be special handling of the Array PrimOps in here HWL -} - -primOpCosts primOp - | primOp `elem` floatOps = Cost (0, 0, 0, 0, 1) :: CostRes - | primOp `elem` gmpOps = Cost (30, 5, 10, 10, 0) :: CostRes -- GUESS; check it - | otherwise = Cost (1, 0, 0, 0, 0) - -\end{code} diff --git a/ghc/compiler/absCSyn/MachOp.hs b/ghc/compiler/absCSyn/MachOp.hs deleted file mode 100644 index 087a403f86..0000000000 --- a/ghc/compiler/absCSyn/MachOp.hs +++ /dev/null @@ -1,460 +0,0 @@ - -module MachOp ( MachOp(..), pprMachOp, - isDefinitelyInlineMachOp, - isCommutableMachOp, - isComparisonMachOp, - resultRepOfMachOp - ) -where - -#include "HsVersions.h" - -import PrimRep ( PrimRep(..) ) -import Outputable - - -{- Machine-level primops; ones which we can reasonably delegate to the - native code generators to handle. Basically contains C's primops - and no others. - - Nomenclature: all ops indicate width and signedness, where - appropriate. Widths: 8/16/32/64 means the given size, obviously. - Nat means the operation works on STG word sized objects. - Signedness: S means signed, U means unsigned. For operations where - signedness is irrelevant or makes no difference (for example - integer add), the signedness component is omitted. - - An exception: NatP is a ptr-typed native word. From the point of - view of the native code generators this distinction is irrelevant, - but the C code generator sometimes needs this info to emit the - right casts. --} - -data MachOp - - -- OPS at the native word size - = MO_Nat_Add -- + - | MO_Nat_Sub -- - - | MO_Nat_Eq - | MO_Nat_Ne - - | MO_NatS_Ge - | MO_NatS_Le - | MO_NatS_Gt - | MO_NatS_Lt - - | MO_NatU_Ge - | MO_NatU_Le - | MO_NatU_Gt - | MO_NatU_Lt - - | MO_NatS_Mul -- low word of signed * - | MO_NatS_MulMayOflo -- nonzero if high word of signed * might contain useful info - | MO_NatS_Quot -- signed / (same semantics as IntQuotOp) - | MO_NatS_Rem -- signed % (same semantics as IntRemOp) - | MO_NatS_Neg -- unary - - - | MO_NatU_Mul -- low word of unsigned * - | MO_NatU_Quot -- unsigned / (same semantics as WordQuotOp) - | MO_NatU_Rem -- unsigned % (same semantics as WordRemOp) - - | MO_Nat_And - | MO_Nat_Or - | MO_Nat_Xor - | MO_Nat_Not - | MO_Nat_Shl - | MO_Nat_Shr - | MO_Nat_Sar - - -- OPS at 32 bits regardless of word size - | MO_32U_Eq - | MO_32U_Ne - | MO_32U_Ge - | MO_32U_Le - | MO_32U_Gt - | MO_32U_Lt - - -- IEEE754 Double ops - | MO_Dbl_Eq - | MO_Dbl_Ne - | MO_Dbl_Ge - | MO_Dbl_Le - | MO_Dbl_Gt - | MO_Dbl_Lt - - | MO_Dbl_Add - | MO_Dbl_Sub - | MO_Dbl_Mul - | MO_Dbl_Div - | MO_Dbl_Pwr - - | MO_Dbl_Sin - | MO_Dbl_Cos - | MO_Dbl_Tan - | MO_Dbl_Sinh - | MO_Dbl_Cosh - | MO_Dbl_Tanh - | MO_Dbl_Asin - | MO_Dbl_Acos - | MO_Dbl_Atan - | MO_Dbl_Log - | MO_Dbl_Exp - | MO_Dbl_Sqrt - | MO_Dbl_Neg - - -- IEEE754 Float ops - | MO_Flt_Add - | MO_Flt_Sub - | MO_Flt_Mul - | MO_Flt_Div - | MO_Flt_Pwr - - | MO_Flt_Eq - | MO_Flt_Ne - | MO_Flt_Ge - | MO_Flt_Le - | MO_Flt_Gt - | MO_Flt_Lt - - | MO_Flt_Sin - | MO_Flt_Cos - | MO_Flt_Tan - | MO_Flt_Sinh - | MO_Flt_Cosh - | MO_Flt_Tanh - | MO_Flt_Asin - | MO_Flt_Acos - | MO_Flt_Atan - | MO_Flt_Log - | MO_Flt_Exp - | MO_Flt_Neg - | MO_Flt_Sqrt - - -- Conversions. Some of these are NOPs, in which case they - -- are here usually to placate the C code generator. - | MO_32U_to_NatS - | MO_NatS_to_32U - - | MO_NatS_to_Dbl - | MO_Dbl_to_NatS - - | MO_NatS_to_Flt - | MO_Flt_to_NatS - - | MO_NatS_to_NatU - | MO_NatU_to_NatS - - | MO_NatS_to_NatP - | MO_NatP_to_NatS - | MO_NatU_to_NatP - | MO_NatP_to_NatU - - | MO_Dbl_to_Flt - | MO_Flt_to_Dbl - - | MO_8S_to_NatS - | MO_16S_to_NatS - | MO_32S_to_NatS - | MO_8U_to_NatU - | MO_16U_to_NatU - | MO_32U_to_NatU - - | MO_8U_to_32U -- zero extend - | MO_32U_to_8U -- mask out all but lowest byte - - deriving Eq - - - --- Almost, but not quite == text . derived show -pprMachOp :: MachOp -> SDoc - -pprMachOp MO_Nat_Add = text "MO_Nat_Add" -pprMachOp MO_Nat_Sub = text "MO_Nat_Sub" -pprMachOp MO_Nat_Eq = text "MO_Nat_Eq" -pprMachOp MO_Nat_Ne = text "MO_Nat_Ne" - -pprMachOp MO_NatS_Ge = text "MO_NatS_Ge" -pprMachOp MO_NatS_Le = text "MO_NatS_Le" -pprMachOp MO_NatS_Gt = text "MO_NatS_Gt" -pprMachOp MO_NatS_Lt = text "MO_NatS_Lt" - -pprMachOp MO_NatU_Ge = text "MO_NatU_Ge" -pprMachOp MO_NatU_Le = text "MO_NatU_Le" -pprMachOp MO_NatU_Gt = text "MO_NatU_Gt" -pprMachOp MO_NatU_Lt = text "MO_NatU_Lt" - -pprMachOp MO_NatS_Mul = text "MO_NatS_Mul" -pprMachOp MO_NatS_MulMayOflo = text "MO_NatS_MulMayOflo" -pprMachOp MO_NatS_Quot = text "MO_NatS_Quot" -pprMachOp MO_NatS_Rem = text "MO_NatS_Rem" -pprMachOp MO_NatS_Neg = text "MO_NatS_Neg" - -pprMachOp MO_NatU_Mul = text "MO_NatU_Mul" -pprMachOp MO_NatU_Quot = text "MO_NatU_Quot" -pprMachOp MO_NatU_Rem = text "MO_NatU_Rem" - -pprMachOp MO_Nat_And = text "MO_Nat_And" -pprMachOp MO_Nat_Or = text "MO_Nat_Or" -pprMachOp MO_Nat_Xor = text "MO_Nat_Xor" -pprMachOp MO_Nat_Not = text "MO_Nat_Not" -pprMachOp MO_Nat_Shl = text "MO_Nat_Shl" -pprMachOp MO_Nat_Shr = text "MO_Nat_Shr" -pprMachOp MO_Nat_Sar = text "MO_Nat_Sar" - -pprMachOp MO_32U_Eq = text "MO_32U_Eq" -pprMachOp MO_32U_Ne = text "MO_32U_Ne" -pprMachOp MO_32U_Ge = text "MO_32U_Ge" -pprMachOp MO_32U_Le = text "MO_32U_Le" -pprMachOp MO_32U_Gt = text "MO_32U_Gt" -pprMachOp MO_32U_Lt = text "MO_32U_Lt" - -pprMachOp MO_Dbl_Eq = text "MO_Dbl_Eq" -pprMachOp MO_Dbl_Ne = text "MO_Dbl_Ne" -pprMachOp MO_Dbl_Ge = text "MO_Dbl_Ge" -pprMachOp MO_Dbl_Le = text "MO_Dbl_Le" -pprMachOp MO_Dbl_Gt = text "MO_Dbl_Gt" -pprMachOp MO_Dbl_Lt = text "MO_Dbl_Lt" - -pprMachOp MO_Dbl_Add = text "MO_Dbl_Add" -pprMachOp MO_Dbl_Sub = text "MO_Dbl_Sub" -pprMachOp MO_Dbl_Mul = text "MO_Dbl_Mul" -pprMachOp MO_Dbl_Div = text "MO_Dbl_Div" -pprMachOp MO_Dbl_Pwr = text "MO_Dbl_Pwr" - -pprMachOp MO_Dbl_Sin = text "MO_Dbl_Sin" -pprMachOp MO_Dbl_Cos = text "MO_Dbl_Cos" -pprMachOp MO_Dbl_Tan = text "MO_Dbl_Tan" -pprMachOp MO_Dbl_Sinh = text "MO_Dbl_Sinh" -pprMachOp MO_Dbl_Cosh = text "MO_Dbl_Cosh" -pprMachOp MO_Dbl_Tanh = text "MO_Dbl_Tanh" -pprMachOp MO_Dbl_Asin = text "MO_Dbl_Asin" -pprMachOp MO_Dbl_Acos = text "MO_Dbl_Acos" -pprMachOp MO_Dbl_Atan = text "MO_Dbl_Atan" -pprMachOp MO_Dbl_Log = text "MO_Dbl_Log" -pprMachOp MO_Dbl_Exp = text "MO_Dbl_Exp" -pprMachOp MO_Dbl_Sqrt = text "MO_Dbl_Sqrt" -pprMachOp MO_Dbl_Neg = text "MO_Dbl_Neg" - -pprMachOp MO_Flt_Add = text "MO_Flt_Add" -pprMachOp MO_Flt_Sub = text "MO_Flt_Sub" -pprMachOp MO_Flt_Mul = text "MO_Flt_Mul" -pprMachOp MO_Flt_Div = text "MO_Flt_Div" -pprMachOp MO_Flt_Pwr = text "MO_Flt_Pwr" - -pprMachOp MO_Flt_Eq = text "MO_Flt_Eq" -pprMachOp MO_Flt_Ne = text "MO_Flt_Ne" -pprMachOp MO_Flt_Ge = text "MO_Flt_Ge" -pprMachOp MO_Flt_Le = text "MO_Flt_Le" -pprMachOp MO_Flt_Gt = text "MO_Flt_Gt" -pprMachOp MO_Flt_Lt = text "MO_Flt_Lt" - -pprMachOp MO_Flt_Sin = text "MO_Flt_Sin" -pprMachOp MO_Flt_Cos = text "MO_Flt_Cos" -pprMachOp MO_Flt_Tan = text "MO_Flt_Tan" -pprMachOp MO_Flt_Sinh = text "MO_Flt_Sinh" -pprMachOp MO_Flt_Cosh = text "MO_Flt_Cosh" -pprMachOp MO_Flt_Tanh = text "MO_Flt_Tanh" -pprMachOp MO_Flt_Asin = text "MO_Flt_Asin" -pprMachOp MO_Flt_Acos = text "MO_Flt_Acos" -pprMachOp MO_Flt_Atan = text "MO_Flt_Atan" -pprMachOp MO_Flt_Log = text "MO_Flt_Log" -pprMachOp MO_Flt_Exp = text "MO_Flt_Exp" -pprMachOp MO_Flt_Sqrt = text "MO_Flt_Sqrt" -pprMachOp MO_Flt_Neg = text "MO_Flt_Neg" - -pprMachOp MO_32U_to_NatS = text "MO_32U_to_NatS" -pprMachOp MO_NatS_to_32U = text "MO_NatS_to_32U" - -pprMachOp MO_NatS_to_Dbl = text "MO_NatS_to_Dbl" -pprMachOp MO_Dbl_to_NatS = text "MO_Dbl_to_NatS" - -pprMachOp MO_NatS_to_Flt = text "MO_NatS_to_Flt" -pprMachOp MO_Flt_to_NatS = text "MO_Flt_to_NatS" - -pprMachOp MO_NatS_to_NatU = text "MO_NatS_to_NatU" -pprMachOp MO_NatU_to_NatS = text "MO_NatU_to_NatS" - -pprMachOp MO_NatS_to_NatP = text "MO_NatS_to_NatP" -pprMachOp MO_NatP_to_NatS = text "MO_NatP_to_NatS" -pprMachOp MO_NatU_to_NatP = text "MO_NatU_to_NatP" -pprMachOp MO_NatP_to_NatU = text "MO_NatP_to_NatU" - -pprMachOp MO_Dbl_to_Flt = text "MO_Dbl_to_Flt" -pprMachOp MO_Flt_to_Dbl = text "MO_Flt_to_Dbl" - -pprMachOp MO_8S_to_NatS = text "MO_8S_to_NatS" -pprMachOp MO_16S_to_NatS = text "MO_16S_to_NatS" -pprMachOp MO_32S_to_NatS = text "MO_32S_to_NatS" - -pprMachOp MO_8U_to_NatU = text "MO_8U_to_NatU" -pprMachOp MO_16U_to_NatU = text "MO_16U_to_NatU" -pprMachOp MO_32U_to_NatU = text "MO_32U_to_NatU" - -pprMachOp MO_8U_to_32U = text "MO_8U_to_32U" -pprMachOp MO_32U_to_8U = text "MO_32U_to_8U" - - - --- Non-exported helper enumeration: -data MO_Prop - = MO_Commutable - | MO_DefinitelyInline - | MO_Comparison - deriving Eq - -comm = MO_Commutable -inline = MO_DefinitelyInline -comp = MO_Comparison - - --- If in doubt, return False. This generates worse code on the --- via-C route, but has no effect on the native code routes. --- Remember that claims about definitely inline have to be true --- regardless of what the C compiler does, so we need to be --- careful about boundary cases like sqrt which are sometimes --- implemented in software and sometimes in hardware. -isDefinitelyInlineMachOp :: MachOp -> Bool -isDefinitelyInlineMachOp mop = inline `elem` snd (machOpProps mop) - --- If in doubt, return False. This generates worse code on the --- native routes, but is otherwise harmless. -isCommutableMachOp :: MachOp -> Bool -isCommutableMachOp mop = comm `elem` snd (machOpProps mop) - --- If in doubt, return False. This generates worse code on the --- native routes, but is otherwise harmless. -isComparisonMachOp :: MachOp -> Bool -isComparisonMachOp mop = comp `elem` snd (machOpProps mop) - --- Find the PrimRep for the returned value of the MachOp. -resultRepOfMachOp :: MachOp -> PrimRep -resultRepOfMachOp mop = fst (machOpProps mop) - --- This bit does the real work. -machOpProps :: MachOp -> (PrimRep, [MO_Prop]) - -machOpProps MO_Nat_Add = (IntRep, [inline, comm]) -machOpProps MO_Nat_Sub = (IntRep, [inline]) -machOpProps MO_Nat_Eq = (IntRep, [inline, comp, comm]) -machOpProps MO_Nat_Ne = (IntRep, [inline, comp, comm]) - -machOpProps MO_NatS_Ge = (IntRep, [inline, comp]) -machOpProps MO_NatS_Le = (IntRep, [inline, comp]) -machOpProps MO_NatS_Gt = (IntRep, [inline, comp]) -machOpProps MO_NatS_Lt = (IntRep, [inline, comp]) - -machOpProps MO_NatU_Ge = (IntRep, [inline, comp]) -machOpProps MO_NatU_Le = (IntRep, [inline, comp]) -machOpProps MO_NatU_Gt = (IntRep, [inline, comp]) -machOpProps MO_NatU_Lt = (IntRep, [inline, comp]) - -machOpProps MO_NatS_Mul = (IntRep, [inline, comm]) -machOpProps MO_NatS_MulMayOflo = (IntRep, [inline, comm]) -machOpProps MO_NatS_Quot = (IntRep, [inline]) -machOpProps MO_NatS_Rem = (IntRep, [inline]) -machOpProps MO_NatS_Neg = (IntRep, [inline]) - -machOpProps MO_NatU_Mul = (WordRep, [inline, comm]) -machOpProps MO_NatU_Quot = (WordRep, [inline]) -machOpProps MO_NatU_Rem = (WordRep, [inline]) - -machOpProps MO_Nat_And = (IntRep, [inline, comm]) -machOpProps MO_Nat_Or = (IntRep, [inline, comm]) -machOpProps MO_Nat_Xor = (IntRep, [inline, comm]) -machOpProps MO_Nat_Not = (IntRep, [inline]) -machOpProps MO_Nat_Shl = (IntRep, [inline]) -machOpProps MO_Nat_Shr = (IntRep, [inline]) -machOpProps MO_Nat_Sar = (IntRep, [inline]) - -machOpProps MO_32U_Eq = (IntRep, [inline, comp, comm]) -machOpProps MO_32U_Ne = (IntRep, [inline, comp, comm]) -machOpProps MO_32U_Ge = (IntRep, [inline, comp]) -machOpProps MO_32U_Le = (IntRep, [inline, comp]) -machOpProps MO_32U_Gt = (IntRep, [inline, comp]) -machOpProps MO_32U_Lt = (IntRep, [inline, comp]) - -machOpProps MO_Dbl_Eq = (IntRep, [inline, comp, comm]) -machOpProps MO_Dbl_Ne = (IntRep, [inline, comp, comm]) -machOpProps MO_Dbl_Ge = (IntRep, [inline, comp]) -machOpProps MO_Dbl_Le = (IntRep, [inline, comp]) -machOpProps MO_Dbl_Gt = (IntRep, [inline, comp]) -machOpProps MO_Dbl_Lt = (IntRep, [inline, comp]) - -machOpProps MO_Dbl_Add = (DoubleRep, [inline, comm]) -machOpProps MO_Dbl_Sub = (DoubleRep, [inline]) -machOpProps MO_Dbl_Mul = (DoubleRep, [inline, comm]) -machOpProps MO_Dbl_Div = (DoubleRep, [inline]) -machOpProps MO_Dbl_Pwr = (DoubleRep, []) - -machOpProps MO_Dbl_Sin = (DoubleRep, []) -machOpProps MO_Dbl_Cos = (DoubleRep, []) -machOpProps MO_Dbl_Tan = (DoubleRep, []) -machOpProps MO_Dbl_Sinh = (DoubleRep, []) -machOpProps MO_Dbl_Cosh = (DoubleRep, []) -machOpProps MO_Dbl_Tanh = (DoubleRep, []) -machOpProps MO_Dbl_Asin = (DoubleRep, []) -machOpProps MO_Dbl_Acos = (DoubleRep, []) -machOpProps MO_Dbl_Atan = (DoubleRep, []) -machOpProps MO_Dbl_Log = (DoubleRep, []) -machOpProps MO_Dbl_Exp = (DoubleRep, []) -machOpProps MO_Dbl_Sqrt = (DoubleRep, []) -machOpProps MO_Dbl_Neg = (DoubleRep, [inline]) - -machOpProps MO_Flt_Add = (FloatRep, [inline, comm]) -machOpProps MO_Flt_Sub = (FloatRep, [inline]) -machOpProps MO_Flt_Mul = (FloatRep, [inline, comm]) -machOpProps MO_Flt_Div = (FloatRep, [inline]) -machOpProps MO_Flt_Pwr = (FloatRep, []) - -machOpProps MO_Flt_Eq = (IntRep, [inline, comp, comm]) -machOpProps MO_Flt_Ne = (IntRep, [inline, comp, comm]) -machOpProps MO_Flt_Ge = (IntRep, [inline, comp]) -machOpProps MO_Flt_Le = (IntRep, [inline, comp]) -machOpProps MO_Flt_Gt = (IntRep, [inline, comp]) -machOpProps MO_Flt_Lt = (IntRep, [inline, comp]) - -machOpProps MO_Flt_Sin = (FloatRep, []) -machOpProps MO_Flt_Cos = (FloatRep, []) -machOpProps MO_Flt_Tan = (FloatRep, []) -machOpProps MO_Flt_Sinh = (FloatRep, []) -machOpProps MO_Flt_Cosh = (FloatRep, []) -machOpProps MO_Flt_Tanh = (FloatRep, []) -machOpProps MO_Flt_Asin = (FloatRep, []) -machOpProps MO_Flt_Acos = (FloatRep, []) -machOpProps MO_Flt_Atan = (FloatRep, []) -machOpProps MO_Flt_Log = (FloatRep, []) -machOpProps MO_Flt_Exp = (FloatRep, []) -machOpProps MO_Flt_Sqrt = (FloatRep, []) -machOpProps MO_Flt_Neg = (FloatRep, [inline]) - -machOpProps MO_32U_to_NatS = (IntRep, [inline]) -machOpProps MO_NatS_to_32U = (Word32Rep, [inline]) - -machOpProps MO_NatS_to_Dbl = (DoubleRep, [inline]) -machOpProps MO_Dbl_to_NatS = (IntRep, [inline]) - -machOpProps MO_NatS_to_Flt = (FloatRep, [inline]) -machOpProps MO_Flt_to_NatS = (IntRep, [inline]) - -machOpProps MO_NatS_to_NatU = (WordRep, [inline]) -machOpProps MO_NatU_to_NatS = (IntRep, [inline]) - -machOpProps MO_NatS_to_NatP = (PtrRep, [inline]) -machOpProps MO_NatP_to_NatS = (IntRep, [inline]) -machOpProps MO_NatU_to_NatP = (PtrRep, [inline]) -machOpProps MO_NatP_to_NatU = (WordRep, [inline]) - -machOpProps MO_Dbl_to_Flt = (FloatRep, [inline]) -machOpProps MO_Flt_to_Dbl = (DoubleRep, [inline]) - -machOpProps MO_8S_to_NatS = (IntRep, [inline]) -machOpProps MO_16S_to_NatS = (IntRep, [inline]) -machOpProps MO_32S_to_NatS = (IntRep, [inline]) - -machOpProps MO_8U_to_NatU = (WordRep, [inline]) -machOpProps MO_16U_to_NatU = (WordRep, [inline]) -machOpProps MO_32U_to_NatU = (WordRep, [inline]) - -machOpProps MO_8U_to_32U = (Word32Rep, [inline]) -machOpProps MO_32U_to_8U = (Word8Rep, [inline]) diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs deleted file mode 100644 index 76b1f43f29..0000000000 --- a/ghc/compiler/absCSyn/PprAbsC.lhs +++ /dev/null @@ -1,1804 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% -%************************************************************************ -%* * -\section[PprAbsC]{Pretty-printing Abstract~C} -%* * -%************************************************************************ - -\begin{code} -module PprAbsC ( - writeRealC, - dumpRealC, - pprAmode, - pprMagicId - ) where - -#include "HsVersions.h" - -import IO ( Handle ) - -import PrimRep -import AbsCSyn -import ClosureInfo -import AbsCUtils ( getAmodeRep, nonemptyAbsC, - mixedPtrLocn, mixedTypeLocn - ) - -import ForeignCall ( CCallSpec(..), CCallTarget(..), playSafe, - playThreadSafe, ccallConvAttribute, - ForeignCall(..), DNCallSpec(..), - DNType(..), DNKind(..) ) -import CLabel ( externallyVisibleCLabel, - needsCDecl, pprCLabel, mkClosureLabel, - mkReturnInfoLabel, mkReturnPtLabel, mkClosureTblLabel, - CLabel, CLabelType(..), labelType, labelDynamic - ) - -import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros ) -import CostCentre ( pprCostCentreDecl, pprCostCentreStackDecl ) - -import Costs ( costs, addrModeCosts, CostRes(..), Side(..) ) -import CStrings ( pprCLabelString ) -import FiniteMap ( addToFM, emptyFM, lookupFM, FiniteMap ) -import Literal ( Literal(..) ) -import TyCon ( tyConDataCons ) -import Name ( NamedThing(..) ) -import Maybes ( catMaybes ) -import PrimOp ( primOpNeedsWrapper ) -import MachOp ( MachOp(..) ) -import PrimRep ( isFloatingRep, PrimRep(..), getPrimRepSize ) -import Unique ( pprUnique, Unique{-instance NamedThing-} ) -import UniqSet ( emptyUniqSet, elementOfUniqSet, - addOneToUniqSet, UniqSet - ) -import StgSyn ( StgOp(..) ) -import Outputable -import FastString -import Util ( lengthExceeds ) - -#if __GLASGOW_HASKELL__ >= 504 -import Data.Array.ST -#endif - -#ifdef DEBUG -import Util ( listLengthCmp ) -#endif - -import Maybe ( isJust ) -import GLAEXTS -import MONAD_ST - -infixr 9 `thenTE` -\end{code} - -For spitting out the costs of an abstract~C expression, @writeRealC@ -now not only prints the C~code of the @absC@ arg but also adds a macro -call to a cost evaluation function @GRAN_EXEC@. For that, -@pprAbsC@ has a new ``costs'' argument. %% HWL - -\begin{code} -{- -writeRealC :: Handle -> AbstractC -> IO () -writeRealC handle absC - -- avoid holding on to the whole of absC in the !Gransim case. - if opt_GranMacros - then printForCFast fp (pprAbsC absC (costs absC)) - else printForCFast fp (pprAbsC absC (panic "costs")) - --printForC handle (pprAbsC absC (panic "costs")) -dumpRealC :: AbstractC -> SDoc -dumpRealC absC = pprAbsC absC (costs absC) --} - -writeRealC :: Handle -> AbstractC -> IO () ---writeRealC handle absC = --- _scc_ "writeRealC" --- printDoc LeftMode handle (pprAbsC absC (costs absC)) - -writeRealC handle absC - | opt_GranMacros = _scc_ "writeRealC" printForC handle $ - pprCode CStyle (pprAbsC absC (costs absC)) - | otherwise = _scc_ "writeRealC" printForC handle $ - pprCode CStyle (pprAbsC absC (panic "costs")) - -dumpRealC :: AbstractC -> SDoc -dumpRealC absC - | opt_GranMacros = pprCode CStyle (pprAbsC absC (costs absC)) - | otherwise = pprCode CStyle (pprAbsC absC (panic "costs")) - -\end{code} - -This emits the macro, which is used in GrAnSim to compute the total costs -from a cost 5 tuple. %% HWL - -\begin{code} -emitMacro :: CostRes -> SDoc - -emitMacro _ | not opt_GranMacros = empty - -emitMacro (Cost (i,b,l,s,f)) - = hcat [ ptext SLIT("GRAN_EXEC"), char '(', - int i, comma, int b, comma, int l, comma, - int s, comma, int f, pp_paren_semi ] - -pp_paren_semi = text ");" -\end{code} - -New type: Now pprAbsC also takes the costs for evaluating the Abstract C -code as an argument (that's needed when spitting out the GRAN_EXEC macro -which must be done before the return i.e. inside absC code) HWL - -\begin{code} -pprAbsC :: AbstractC -> CostRes -> SDoc -pprAbsC AbsCNop _ = empty -pprAbsC (AbsCStmts s1 s2) c = ($$) (pprAbsC s1 c) (pprAbsC s2 c) - -pprAbsC (CAssign dest src) _ = pprAssign (getAmodeRep dest) dest src - -pprAbsC (CJump target) c - = ($$) (hcat [emitMacro c {-WDP:, text "/* <--++ CJump */"-} ]) - (hcat [ text jmp_lit, pprAmode target, pp_paren_semi ]) - -pprAbsC (CFallThrough target) c - = ($$) (hcat [emitMacro c {-WDP:, text "/* <--++ CFallThrough */"-} ]) - (hcat [ text jmp_lit, pprAmode target, pp_paren_semi ]) - --- -------------------------------------------------------------------------- --- Spit out GRAN_EXEC macro immediately before the return HWL - -pprAbsC (CReturn am return_info) c - = ($$) (hcat [emitMacro c {-WDP:, text "/* <---- CReturn */"-} ]) - (hcat [text jmp_lit, target, pp_paren_semi ]) - where - target = case return_info of - DirectReturn -> hcat [ptext SLIT("ENTRY_CODE"), lparen, - pprAmode am, rparen] - DynamicVectoredReturn am' -> mk_vector (pprAmode am') - StaticVectoredReturn n -> mk_vector (int n) -- Always positive - mk_vector x = hcat [ptext SLIT("RET_VEC"), char '(', pprAmode am, comma, - x, rparen ] - -pprAbsC (CSplitMarker) _ = ptext SLIT("__STG_SPLIT_MARKER") - --- we optimise various degenerate cases of CSwitches. - --- -------------------------------------------------------------------------- --- Assume: CSwitch is also end of basic block --- costs function yields nullCosts for whole switch --- ==> inherited costs c are those of basic block up to switch --- ==> inherit c + costs for the corresponding branch --- HWL --- -------------------------------------------------------------------------- - -pprAbsC (CSwitch discrim [] deflt) c - = pprAbsC deflt (c + costs deflt) - -- Empty alternative list => no costs for discrim as nothing cond. here HWL - -pprAbsC (CSwitch discrim [(tag,alt_code)] deflt) c -- only one alt - = case (nonemptyAbsC deflt) of - Nothing -> -- one alt and no default - pprAbsC alt_code (c + costs alt_code) - -- Nothing conditional in here either HWL - - Just dc -> -- make it an "if" - do_if_stmt discrim tag alt_code dc c - --- What problem is the re-ordering trying to solve ? -pprAbsC (CSwitch discrim [(tag1@(MachInt i1), alt_code1), - (tag2@(MachInt i2), alt_code2)] deflt) c - | empty_deflt && ((i1 == 0 && i2 == 1) || (i1 == 1 && i2 == 0)) - = if (i1 == 0) then - do_if_stmt discrim tag1 alt_code1 alt_code2 c - else - do_if_stmt discrim tag2 alt_code2 alt_code1 c - where - empty_deflt = not (isJust (nonemptyAbsC deflt)) - -pprAbsC (CSwitch discrim alts deflt) c -- general case - | isFloatingRep (getAmodeRep discrim) - = pprAbsC (foldr ( \ a -> CSwitch discrim [a]) deflt alts) c - | otherwise - = vcat [ - hcat [text "switch (", pp_discrim, text ") {"], - nest 2 (vcat (map ppr_alt alts)), - (case (nonemptyAbsC deflt) of - Nothing -> empty - Just dc -> - nest 2 (vcat [ptext SLIT("default:"), - pprAbsC dc (c + switch_head_cost - + costs dc), - ptext SLIT("break;")])), - char '}' ] - where - pp_discrim - = pprAmode discrim - - ppr_alt (lit, absC) - = vcat [ hcat [ptext SLIT("case "), pprBasicLit lit, char ':'], - nest 2 (($$) (pprAbsC absC (c + switch_head_cost + costs absC)) - (ptext SLIT("break;"))) ] - - -- Costs for addressing header of switch and cond. branching -- HWL - switch_head_cost = addrModeCosts discrim Rhs + (Cost (0, 1, 0, 0, 0)) - -pprAbsC stmt@(COpStmt results (StgFCallOp fcall uniq) args vol_regs) _ - = pprFCall fcall uniq args results vol_regs - -pprAbsC stmt@(COpStmt results (StgPrimOp op) args vol_regs) _ - = let - non_void_args = grab_non_void_amodes args - non_void_results = grab_non_void_amodes results - -- if just one result, we print in the obvious "assignment" style; - -- if 0 or many results, we emit a macro call, w/ the results - -- followed by the arguments. The macro presumably knows which - -- are which :-) - - the_op = ppr_op_call non_void_results non_void_args - -- liveness mask is *in* the non_void_args - in - if primOpNeedsWrapper op then - case (ppr_vol_regs vol_regs) of { (pp_saves, pp_restores) -> - vcat [ pp_saves, - the_op, - pp_restores - ] - } - else - the_op - where - ppr_op_call results args - = hcat [ ppr op, lparen, - hcat (punctuate comma (map ppr_op_result results)), - if null results || null args then empty else comma, - hcat (punctuate comma (map pprAmode args)), - pp_paren_semi ] - - ppr_op_result r = ppr_amode r - -- primop macros do their own casting of result; - -- hence we can toss the provided cast... - --- NEW CASES FOR EXPANDED PRIMOPS - -pprAbsC stmt@(CMachOpStmt res mop [arg1,arg2] maybe_vols) _ - = let prefix_fn = mop `elem` [MO_Dbl_Pwr, MO_Flt_Pwr, MO_NatS_MulMayOflo] - in - case ppr_maybe_vol_regs maybe_vols of {(saves,restores) -> - saves $$ - hcat ( - [ppr_amode res, equals] - ++ (if prefix_fn - then [pprMachOp_for_C mop, parens (pprAmode arg1 <> comma <> pprAmode arg2)] - else [pprAmode arg1, pprMachOp_for_C mop, pprAmode arg2]) - ++ [semi] - ) - $$ restores - } - -pprAbsC stmt@(CMachOpStmt res mop [arg1] maybe_vols) _ - = case ppr_maybe_vol_regs maybe_vols of {(saves,restores) -> - saves $$ - hcat [ppr_amode res, equals, - pprMachOp_for_C mop, parens (pprAmode arg1), - semi] - $$ restores - } - -pprAbsC stmt@(CSequential stuff) c - = vcat (map (flip pprAbsC c) stuff) - --- end of NEW CASES FOR EXPANDED PRIMOPS - -pprAbsC stmt@(CSRT lbl closures) c - = case (pprTempAndExternDecls stmt) of { (_, pp_exts) -> - pp_exts - $$ ptext SLIT("SRT") <> lparen <> pprCLabel lbl <> rparen - $$ nest 2 (hcat (punctuate comma (map pp_closure_lbl closures))) - <> ptext SLIT("};") - } - -pprAbsC stmt@(CBitmap liveness@(Liveness lbl size mask)) c - = pprWordArray lbl (mkWordCLit (fromIntegral size) : bitmapAddrModes mask) - -pprAbsC stmt@(CSRTDesc desc_lbl srt_lbl off len bitmap) c - = pprWordArray desc_lbl ( - CAddr (CIndex (CLbl srt_lbl DataPtrRep) (mkIntCLit off) WordRep) : - mkWordCLit (fromIntegral len) : - bitmapAddrModes bitmap - ) - -pprAbsC (CSimultaneous abs_c) c - = hcat [ptext SLIT("{{"), pprAbsC abs_c c, ptext SLIT("}}")] - -pprAbsC (CCheck macro as code) c - = hcat [ptext (cCheckMacroText macro), lparen, - hcat (punctuate comma (map ppr_amode as)), comma, - pprAbsC code c, pp_paren_semi - ] -pprAbsC (CMacroStmt macro as) _ - = hcat [ptext (cStmtMacroText macro), lparen, - hcat (punctuate comma (map ppr_amode as)),pp_paren_semi] -- no casting -pprAbsC (CCallProfCtrMacro op as) _ - = hcat [ftext op, lparen, - hcat (punctuate comma (map ppr_amode as)),pp_paren_semi] -pprAbsC (CCallProfCCMacro op as) _ - = hcat [ftext op, lparen, - hcat (punctuate comma (map ppr_amode as)),pp_paren_semi] -pprAbsC stmt@(CCallTypedef is_tdef (CCallSpec op_str cconv _) uniq results args) _ - = hsep [ ptext (if is_tdef then SLIT("typedef") else SLIT("extern")) - , ccall_res_ty - , fun_nm - , parens (hsep (punctuate comma ccall_decl_ty_args)) - ] <> semi - where - {- - In the non-casm case, to ensure that we're entering the given external - entry point using the correct calling convention, we have to do the following: - - - When entering via a function pointer (the `dynamic' case) using the specified - calling convention, we emit a typedefn declaration attributed with the - calling convention to use together with the result and parameter types we're - assuming. Coerce the function pointer to this type and go. - - - to enter the function at a given code label, we emit an extern declaration - for the label here, stating the calling convention together with result and - argument types we're assuming. - - The C compiler will hopefully use this extern declaration to good effect, - reporting any discrepancies between our extern decl and any other that - may be in scope. - - Re: calling convention, notice that gcc (2.8.1 and egcs-1.0.2) will for - the external function `foo' use the calling convention of the first `foo' - prototype it encounters (nor does it complain about conflicting attribute - declarations). The consequence of this is that you cannot override the - calling convention of `foo' using an extern declaration (you'd have to use - a typedef), but why you would want to do such a thing in the first place - is totally beyond me. - - ToDo: petition the gcc folks to add code to warn about conflicting attribute - declarations. - - -} - - fun_nm - | is_tdef = parens (text (ccallConvAttribute cconv) <+> char '*' <> ccall_fun_ty) - | otherwise = text (ccallConvAttribute cconv) <+> ccall_fun_ty - - ccall_fun_ty = - case op_str of - DynamicTarget -> ptext SLIT("_ccall_fun_ty") <> ppr uniq - StaticTarget x -> pprCLabelString x - - ccall_res_ty = - case non_void_results of - [] -> ptext SLIT("void") - [amode] -> ppr (getAmodeRep amode) - _ -> panic "pprAbsC{CCallTypedef}: ccall_res_ty" - - ccall_decl_ty_args - | is_tdef = tail ccall_arg_tys - | otherwise = ccall_arg_tys - - ccall_arg_tys = map (ppr . getAmodeRep) non_void_args - - -- the first argument will be the "I/O world" token (a VoidRep) - -- all others should be non-void - non_void_args = - let nvas = init args - in ASSERT (all non_void nvas) nvas - - -- there will usually be two results: a (void) state which we - -- should ignore and a (possibly void) result. - non_void_results = - let nvrs = grab_non_void_amodes results - in ASSERT (listLengthCmp nvrs 1 /= GT) nvrs - -pprAbsC (CCodeBlock lbl abs_C) _ - = if not (isJust(nonemptyAbsC abs_C)) then - pprTrace "pprAbsC: curious empty code block for" (pprCLabel lbl) empty - else - case (pprTempAndExternDecls abs_C) of { (pp_temps, pp_exts) -> - vcat [ - empty, - pp_exts, - hcat [text (if (externallyVisibleCLabel lbl) - then "FN_(" -- abbreviations to save on output - else "IF_("), - pprCLabel lbl, text ") {"], - - pp_temps, - - nest 8 (ptext SLIT("FB_")), - nest 8 (pprAbsC abs_C (costs abs_C)), - nest 8 (ptext SLIT("FE_")), - char '}', - char ' ' ] - } - - -pprAbsC (CInitHdr cl_info amode cost_centre size) _ - = hcat [ ptext SLIT("SET_HDR_"), char '(', - ppr_amode amode, comma, - pprCLabelAddr info_lbl, comma, - if_profiling (pprAmode cost_centre), comma, - if_profiling (int size), - pp_paren_semi ] - where - info_lbl = infoTableLabelFromCI cl_info - - -pprAbsC stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _ - = case (pprTempAndExternDecls stmt) of { (_, pp_exts) -> - vcat [ - pp_exts, - hcat [ - ptext SLIT("SET_STATIC_HDR"), char '(', - pprCLabel closure_lbl, comma, - pprCLabel info_lbl, comma, - if_profiling (pprAmode cost_centre), comma, - ppLocalness closure_lbl, comma, - ppLocalnessMacro True{-include dyn-} info_lbl, - char ')' - ], - nest 2 (ppr_payload amodes), - ptext SLIT("};") ] - } - where - info_lbl = infoTableLabelFromCI cl_info - - ppr_payload [] = empty - ppr_payload ls = - comma <+> - (braces $ hsep $ punctuate comma $ - map (text "(L_)" <>) (foldr ppr_item [] ls)) - - ppr_item item rest - | rep == VoidRep = rest - | rep == FloatRep = ppr_amode (floatToWord item) : rest - | rep == DoubleRep = map ppr_amode (doubleToWords item) ++ rest - | otherwise = ppr_amode item : rest - where - rep = getAmodeRep item - -pprAbsC stmt@(CClosureInfoAndCode cl_info entry) _ - = pprWordArray info_lbl (mkInfoTable cl_info) - $$ let stuff = CCodeBlock entry_lbl entry in - pprAbsC stuff (costs stuff) - where - entry_lbl = entryLabelFromCI cl_info - info_lbl = infoTableLabelFromCI cl_info - -pprAbsC stmt@(CClosureTbl tycon) _ - = vcat ( - ptext SLIT("CLOSURE_TBL") <> - lparen <> pprCLabel (mkClosureTblLabel tycon) <> rparen : - punctuate comma ( - map (pp_closure_lbl . mkClosureLabel . getName) (tyConDataCons tycon) - ) - ) $$ ptext SLIT("};") - -pprAbsC stmt@(CRetDirect uniq code srt liveness) _ - = pprWordArray info_lbl (mkRetInfoTable entry_lbl srt liveness) - $$ let stuff = CCodeBlock entry_lbl code in - pprAbsC stuff (costs stuff) - where - info_lbl = mkReturnInfoLabel uniq - entry_lbl = mkReturnPtLabel uniq - -pprAbsC stmt@(CRetVector lbl amodes srt liveness) _ - = pprWordArray lbl (mkVecInfoTable amodes srt liveness) - -pprAbsC stmt@(CModuleInitBlock plain_lbl lbl code) _ - = vcat [ - ptext SLIT("START_MOD_INIT") <> - parens (pprCLabel plain_lbl <> comma <> pprCLabel lbl), - case (pprTempAndExternDecls stmt) of { (_, pp_exts) -> pp_exts }, - pprAbsC code (costs code), - hcat [ptext SLIT("END_MOD_INIT"), lparen, rparen] - ] - -pprAbsC (CCostCentreDecl is_local cc) _ = pprCostCentreDecl is_local cc -pprAbsC (CCostCentreStackDecl ccs) _ = pprCostCentreStackDecl ccs -\end{code} - -Info tables... just arrays of words (the translation is done in -ClosureInfo). - -\begin{code} -pprWordArray lbl amodes - = (case snd (initTE (ppr_decls_Amodes amodes)) of - Just pp -> pp - Nothing -> empty) - $$ hcat [ ppLocalness lbl, ptext SLIT("StgWord "), - pprCLabel lbl, ptext SLIT("[] = {") ] - $$ hcat (punctuate comma (map (castToWord.pprAmode) amodes)) - $$ ptext SLIT("};") - -castToWord s = text "(W_)(" <> s <> char ')' -\end{code} - -\begin{code} --- Print a CMachOp in a way suitable for emitting via C. -pprMachOp_for_C MO_Nat_Add = char '+' -pprMachOp_for_C MO_Nat_Sub = char '-' -pprMachOp_for_C MO_Nat_Eq = text "==" -pprMachOp_for_C MO_Nat_Ne = text "!=" - -pprMachOp_for_C MO_NatS_Ge = text ">=" -pprMachOp_for_C MO_NatS_Le = text "<=" -pprMachOp_for_C MO_NatS_Gt = text ">" -pprMachOp_for_C MO_NatS_Lt = text "<" - -pprMachOp_for_C MO_NatU_Ge = text ">=" -pprMachOp_for_C MO_NatU_Le = text "<=" -pprMachOp_for_C MO_NatU_Gt = text ">" -pprMachOp_for_C MO_NatU_Lt = text "<" - -pprMachOp_for_C MO_NatS_Mul = char '*' -pprMachOp_for_C MO_NatS_MulMayOflo = text "mulIntMayOflo" -pprMachOp_for_C MO_NatS_Quot = char '/' -pprMachOp_for_C MO_NatS_Rem = char '%' -pprMachOp_for_C MO_NatS_Neg = char '-' - -pprMachOp_for_C MO_NatU_Mul = char '*' -pprMachOp_for_C MO_NatU_Quot = char '/' -pprMachOp_for_C MO_NatU_Rem = char '%' - -pprMachOp_for_C MO_Nat_And = text "&" -pprMachOp_for_C MO_Nat_Or = text "|" -pprMachOp_for_C MO_Nat_Xor = text "^" -pprMachOp_for_C MO_Nat_Not = text "~" -pprMachOp_for_C MO_Nat_Shl = text "<<" -pprMachOp_for_C MO_Nat_Shr = text ">>" -pprMachOp_for_C MO_Nat_Sar = text ">>" - -pprMachOp_for_C MO_32U_Eq = text "==" -pprMachOp_for_C MO_32U_Ne = text "!=" -pprMachOp_for_C MO_32U_Ge = text ">=" -pprMachOp_for_C MO_32U_Le = text "<=" -pprMachOp_for_C MO_32U_Gt = text ">" -pprMachOp_for_C MO_32U_Lt = text "<" - -pprMachOp_for_C MO_Dbl_Eq = text "==" -pprMachOp_for_C MO_Dbl_Ne = text "!=" -pprMachOp_for_C MO_Dbl_Ge = text ">=" -pprMachOp_for_C MO_Dbl_Le = text "<=" -pprMachOp_for_C MO_Dbl_Gt = text ">" -pprMachOp_for_C MO_Dbl_Lt = text "<" - -pprMachOp_for_C MO_Dbl_Add = text "+" -pprMachOp_for_C MO_Dbl_Sub = text "-" -pprMachOp_for_C MO_Dbl_Mul = text "*" -pprMachOp_for_C MO_Dbl_Div = text "/" -pprMachOp_for_C MO_Dbl_Pwr = text "pow" - -pprMachOp_for_C MO_Dbl_Sin = text "sin" -pprMachOp_for_C MO_Dbl_Cos = text "cos" -pprMachOp_for_C MO_Dbl_Tan = text "tan" -pprMachOp_for_C MO_Dbl_Sinh = text "sinh" -pprMachOp_for_C MO_Dbl_Cosh = text "cosh" -pprMachOp_for_C MO_Dbl_Tanh = text "tanh" -pprMachOp_for_C MO_Dbl_Asin = text "asin" -pprMachOp_for_C MO_Dbl_Acos = text "acos" -pprMachOp_for_C MO_Dbl_Atan = text "atan" -pprMachOp_for_C MO_Dbl_Log = text "log" -pprMachOp_for_C MO_Dbl_Exp = text "exp" -pprMachOp_for_C MO_Dbl_Sqrt = text "sqrt" -pprMachOp_for_C MO_Dbl_Neg = text "-" - -pprMachOp_for_C MO_Flt_Add = text "+" -pprMachOp_for_C MO_Flt_Sub = text "-" -pprMachOp_for_C MO_Flt_Mul = text "*" -pprMachOp_for_C MO_Flt_Div = text "/" -pprMachOp_for_C MO_Flt_Pwr = text "pow" - -pprMachOp_for_C MO_Flt_Eq = text "==" -pprMachOp_for_C MO_Flt_Ne = text "!=" -pprMachOp_for_C MO_Flt_Ge = text ">=" -pprMachOp_for_C MO_Flt_Le = text "<=" -pprMachOp_for_C MO_Flt_Gt = text ">" -pprMachOp_for_C MO_Flt_Lt = text "<" - -pprMachOp_for_C MO_Flt_Sin = text "sin" -pprMachOp_for_C MO_Flt_Cos = text "cos" -pprMachOp_for_C MO_Flt_Tan = text "tan" -pprMachOp_for_C MO_Flt_Sinh = text "sinh" -pprMachOp_for_C MO_Flt_Cosh = text "cosh" -pprMachOp_for_C MO_Flt_Tanh = text "tanh" -pprMachOp_for_C MO_Flt_Asin = text "asin" -pprMachOp_for_C MO_Flt_Acos = text "acos" -pprMachOp_for_C MO_Flt_Atan = text "atan" -pprMachOp_for_C MO_Flt_Log = text "log" -pprMachOp_for_C MO_Flt_Exp = text "exp" -pprMachOp_for_C MO_Flt_Sqrt = text "sqrt" -pprMachOp_for_C MO_Flt_Neg = text "-" - -pprMachOp_for_C MO_32U_to_NatS = text "(StgInt)" -pprMachOp_for_C MO_NatS_to_32U = text "(StgWord32)" - -pprMachOp_for_C MO_NatS_to_Dbl = text "(StgDouble)" -pprMachOp_for_C MO_Dbl_to_NatS = text "(StgInt)" - -pprMachOp_for_C MO_NatS_to_Flt = text "(StgFloat)" -pprMachOp_for_C MO_Flt_to_NatS = text "(StgInt)" - -pprMachOp_for_C MO_NatS_to_NatU = text "(StgWord)" -pprMachOp_for_C MO_NatU_to_NatS = text "(StgInt)" - -pprMachOp_for_C MO_NatS_to_NatP = text "(void*)" -pprMachOp_for_C MO_NatP_to_NatS = text "(StgInt)" -pprMachOp_for_C MO_NatU_to_NatP = text "(void*)" -pprMachOp_for_C MO_NatP_to_NatU = text "(StgWord)" - -pprMachOp_for_C MO_Dbl_to_Flt = text "(StgFloat)" -pprMachOp_for_C MO_Flt_to_Dbl = text "(StgDouble)" - -pprMachOp_for_C MO_8S_to_NatS = text "(StgInt8)(StgInt)" -pprMachOp_for_C MO_16S_to_NatS = text "(StgInt16)(StgInt)" -pprMachOp_for_C MO_32S_to_NatS = text "(StgInt32)(StgInt)" - -pprMachOp_for_C MO_8U_to_NatU = text "(StgWord8)(StgWord)" -pprMachOp_for_C MO_16U_to_NatU = text "(StgWord16)(StgWord)" -pprMachOp_for_C MO_32U_to_NatU = text "(StgWord32)(StgWord)" - -pprMachOp_for_C MO_8U_to_32U = text "(StgWord32)" -pprMachOp_for_C MO_32U_to_8U = text "(StgWord8)" - - -ppLocalness lbl - = if (externallyVisibleCLabel lbl) - then empty - else ptext SLIT("static ") - --- Horrible macros for declaring the types and locality of labels (see --- StgMacros.h). - -ppLocalnessMacro include_dyn_prefix clabel = - hcat [ - visiblity_prefix, - dyn_prefix, - case label_type of - ClosureType -> ptext SLIT("C_") - CodeType -> ptext SLIT("F_") - InfoTblType -> ptext SLIT("I_") - RetInfoTblType -> ptext SLIT("RI_") - ClosureTblType -> ptext SLIT("CP_") - DataType -> ptext SLIT("D_") - ] - where - is_visible = externallyVisibleCLabel clabel - label_type = labelType clabel - - visiblity_prefix - | is_visible = char 'E' - | otherwise = char 'I' - - dyn_prefix - | include_dyn_prefix && labelDynamic clabel = char 'D' - | otherwise = empty - -\end{code} - -\begin{code} -jmp_lit = "JMP_(" - -grab_non_void_amodes amodes - = filter non_void amodes - -non_void amode - = case (getAmodeRep amode) of - VoidRep -> False - k -> True -\end{code} - -\begin{code} -ppr_maybe_vol_regs :: Maybe [MagicId] -> (SDoc, SDoc) -ppr_maybe_vol_regs Nothing - = (empty, empty) -ppr_maybe_vol_regs (Just vrs) - = case ppr_vol_regs vrs of - (saves, restores) - -> (pp_basic_saves $$ saves, - pp_basic_restores $$ restores) - -ppr_vol_regs :: [MagicId] -> (SDoc, SDoc) - -ppr_vol_regs [] = (empty, empty) -ppr_vol_regs (VoidReg:rs) = ppr_vol_regs rs -ppr_vol_regs (r:rs) - = let pp_reg = case r of - VanillaReg pk n -> pprVanillaReg n - _ -> pprMagicId r - (more_saves, more_restores) = ppr_vol_regs rs - in - (($$) ((<>) (ptext SLIT("CALLER_SAVE_")) pp_reg) more_saves, - ($$) ((<>) (ptext SLIT("CALLER_RESTORE_")) pp_reg) more_restores) - --- pp_basic_{saves,restores}: The BaseReg, Sp, Hp and --- HpLim (see StgRegs.lh) may need to be saved/restored around CCalls, --- depending on the platform. (The "volatile regs" stuff handles all --- other registers.) Just be *sure* BaseReg is OK before trying to do --- anything else. The correct sequence of saves&restores are --- encoded by the CALLER_*_SYSTEM macros. -pp_basic_saves = ptext SLIT("CALLER_SAVE_SYSTEM") -pp_basic_restores = ptext SLIT("CALLER_RESTORE_SYSTEM") -\end{code} - -\begin{code} -pp_closure_lbl lbl - | labelDynamic lbl = text "DLL_SRT_ENTRY" <> parens (pprCLabel lbl) - | otherwise = char '&' <> pprCLabel lbl -\end{code} - -\begin{code} -if_profiling pretty - = if opt_SccProfilingOn - then pretty - else char '0' -- leave it out! --- --------------------------------------------------------------------------- --- Changes for GrAnSim: --- draw costs for computation in head of if into both branches; --- as no abstractC data structure is given for the head, one is constructed --- guessing unknown values and fed into the costs function --- --------------------------------------------------------------------------- - -do_if_stmt discrim tag alt_code deflt c - = let - cond = hcat [ pprAmode discrim - , ptext SLIT(" == ") - , tcast - , pprAmode (CLit tag) - ] - -- to be absolutely sure that none of the - -- conversion rules hit, e.g., - -- - -- minInt is different to (int)minInt - -- - -- in C (when minInt is a number not a constant - -- expression which evaluates to it.) - -- - tcast = case tag of - MachInt _ -> ptext SLIT("(I_)") - _ -> empty - in - ppr_if_stmt cond - alt_code deflt - (addrModeCosts discrim Rhs) c - -ppr_if_stmt pp_pred then_part else_part discrim_costs c - = vcat [ - hcat [text "if (", pp_pred, text ") {"], - nest 8 (pprAbsC then_part (c + discrim_costs + - (Cost (0, 2, 0, 0, 0)) + - costs then_part)), - (case nonemptyAbsC else_part of Nothing -> empty; Just _ -> text "} else {"), - nest 8 (pprAbsC else_part (c + discrim_costs + - (Cost (0, 1, 0, 0, 0)) + - costs else_part)), - char '}' ] - {- Total costs = inherited costs (before if) + costs for accessing discrim - + costs for cond branch ( = (0, 1, 0, 0, 0) ) - + costs for that alternative - -} -\end{code} - -Historical note: this used to be two separate cases -- one for `ccall' -and one for `casm'. To get round a potential limitation to only 10 -arguments, the numbering of arguments in @process_casm@ was beefed up a -bit. ADR - -Some rough notes on generating code for @CCallOp@: - -1) Evaluate all arguments and stuff them into registers. (done elsewhere) -2) Save any essential registers (heap, stack, etc). - - ToDo: If stable pointers are in use, these must be saved in a place - where the runtime system can get at them so that the Stg world can - be restarted during the call. - -3) Save any temporary registers that are currently in use. -4) Do the call, putting result into a local variable -5) Restore essential registers -6) Restore temporaries - - (This happens after restoration of essential registers because we - might need the @Base@ register to access all the others correctly.) - - Otherwise, copy local variable into result register. - -8) If ccall (not casm), declare the function being called as extern so - that C knows if it returns anything other than an int. - -\begin{pseudocode} -{ ResultType _ccall_result; - basic_saves; - saves; - _ccall_result = f( args ); - basic_restores; - restores; - - return_reg = _ccall_result; -} -\end{pseudocode} - -Amendment to the above: if we can GC, we have to: - -* make sure we save all our registers away where the garbage collector - can get at them. -* be sure that there are no live registers or we're in trouble. - (This can cause problems if you try something foolish like passing - an array or a foreign obj to a _ccall_GC_ thing.) -* increment/decrement the @inCCallGC@ counter before/after the call so - that the runtime check that PerformGC is being used sensibly will work. - -\begin{code} -pprFCall call uniq args results vol_regs - = case call of - CCall (CCallSpec target _cconv safety) -> - vcat [ char '{', - declare_local_vars, -- local var for *result* - vcat local_arg_decls, - makeCall target safety - (process_casm local_vars pp_non_void_args (call_str target)), - assign_results, - char '}' - ] - DNCall (DNCallSpec isStatic kind assem nm argTys resTy) -> - let - resultVar = "_ccall_result" - hasAssemArg = isStatic || kind == DNConstructor - invokeOp = - case kind of - DNMethod - | isStatic -> "DN_invokeStatic" - | otherwise -> "DN_invokeMethod" - DNField - | isStatic -> - if resTy == DNUnit - then "DN_setStatic" - else "DN_getStatic" - | otherwise -> - if resTy == DNUnit - then "DN_setField" - else "DN_getField" - DNConstructor -> "DN_createObject" - - (methArrDecl, methArrInit, methArrName, methArrLen) - | null argTys = (empty, empty, text "NULL", text "0") - | otherwise = - ( text "DotnetArg __meth_args[" <> int (length argTys) <> text "];" - , vcat (zipWith3 (\ idx arg argTy -> - text "__meth_args[" <> int idx <> text "].arg." <> text (toDotnetArgField argTy) <> equals <> ppr_amode arg <> semi $$ - text "__meth_args[" <> int idx <> text "].arg_type=" <> text (toDotnetTy argTy) <> semi) - [0..] - non_void_args - argTys) - , text "__meth_args" - , int (length non_void_args) - ) - in - vcat [ char '{', - declare_local_vars, - vcat local_arg_decls, - vcat [ methArrDecl - , methArrInit - , text "_ccall_result1 =" <+> text invokeOp <> parens ( - hcat (punctuate comma $ - (if hasAssemArg then - ((if null assem then - text "NULL" - else - doubleQuotes (text assem)):) - else - id) $ - [ doubleQuotes $ text nm - , methArrName - , methArrLen - , text (toDotnetTy resTy) - , text "(void*)&" <> text resultVar - ])) <> semi - ], - assign_results, - char '}' - ] - where - (pp_saves, pp_restores) = ppr_vol_regs vol_regs - - makeCall target safety theCall = - vcat [ pp_save_context, theCall, pp_restore_context ] - where - (pp_save_context, pp_restore_context) - | playSafe safety = ( text "{ I_" <+> ppr_uniq_token <> - text "; SUSPEND_THREAD" <> parens thread_macro_args <> semi - , text "RESUME_THREAD" <> parens thread_macro_args <> text ";}" - ) - | otherwise = ( pp_basic_saves $$ pp_saves, - pp_basic_restores $$ pp_restores) - where - thread_macro_args = ppr_uniq_token <> comma <+> - text "rts" <> ppr (playThreadSafe safety) - ppr_uniq_token = text "tok_" <> ppr uniq - - - non_void_args = - let nvas = init args - in ASSERT2 ( all non_void nvas, ppr call <+> hsep (map pprAmode args) ) - nvas - -- the last argument will be the "I/O world" token (a VoidRep) - -- all others should be non-void - - non_void_results = - let nvrs = grab_non_void_amodes results - in ASSERT (forDotnet || listLengthCmp nvrs 1 /= GT) nvrs - -- there will usually be two results: a (void) state which we - -- should ignore and a (possibly void) result. - - (local_arg_decls, pp_non_void_args) - = unzip [ ppr_casm_arg a i | (a,i) <- non_void_args `zip` [1..] ] - - (declare_local_vars, local_vars, assign_results) - = ppr_casm_results non_void_results forDotnet - - forDotnet - = case call of - DNCall{} -> True - _ -> False - - call_str tgt - = case tgt of - StaticTarget fn -> mk_ccall_str (pprCLabelString fn) ccall_args - DynamicTarget -> mk_ccall_str dyn_fun (tail ccall_args) - - ccall_args = zipWith (\ _ i -> char '%' <> int i) non_void_args [0..] - dyn_fun = parens (parens (ptext SLIT("_ccall_fun_ty") <> ppr uniq) <> text "%0") - - - -- Remainder only used for ccall - mk_ccall_str fun_name ccall_fun_args = showSDoc - (hcat [ - if null non_void_results - then empty - else text "%r = ", - lparen, fun_name, lparen, - hcat (punctuate comma ccall_fun_args), - text "));" - ]) - -toDotnetTy :: DNType -> String -toDotnetTy x = - case x of - DNByte -> "Dotnet_Byte" - DNBool -> "Dotnet_Bool" - DNChar -> "Dotnet_Char" - DNDouble -> "Dotnet_Double" - DNFloat -> "Dotnet_Float" - DNInt -> "Dotnet_Int" - DNInt8 -> "Dotnet_Int8" - DNInt16 -> "Dotnet_Int16" - DNInt32 -> "Dotnet_Int32" - DNInt64 -> "Dotnet_Int64" - DNWord8 -> "Dotnet_Word8" - DNWord16 -> "Dotnet_Word16" - DNWord32 -> "Dotnet_Word32" - DNWord64 -> "Dotnet_Word64" - DNPtr -> "Dotnet_Ptr" - DNUnit -> "Dotnet_Unit" - DNObject -> "Dotnet_Object" - DNString -> "Dotnet_String" - -toDotnetArgField :: DNType -> String -toDotnetArgField x = - case x of - DNByte -> "arg_byte" - DNBool -> "arg_bool" - DNChar -> "arg_char" - DNDouble -> "arg_double" - DNFloat -> "arg_float" - DNInt -> "arg_int" - DNInt8 -> "arg_int8" - DNInt16 -> "arg_int16" - DNInt32 -> "arg_int32" - DNInt64 -> "arg_int64" - DNWord8 -> "arg_word8" - DNWord16 -> "arg_word16" - DNWord32 -> "arg_word32" - DNWord64 -> "arg_word64" - DNPtr -> "arg_ptr" - DNUnit -> "arg_ptr" -- can't happen - DNObject -> "arg_obj" - DNString -> "arg_str" - -ppr_casm_arg :: CAddrMode -> Int -> (SDoc, SDoc) - -- (a) decl and assignment, (b) local var to be used later - -ppr_casm_arg amode a_num - = let - a_kind = getAmodeRep amode - pp_amode = pprAmode amode - pp_kind = pprPrimKind a_kind - - local_var = (<>) (ptext SLIT("_ccall_arg")) (int a_num) - - declare_local_var - = hcat [ pp_kind, space, local_var, equals, pp_amode, semi ] - in - (declare_local_var, local_var) -\end{code} - -For l-values, the critical questions are: - -1) Are there any results at all? - - We only allow zero or one results. - -\begin{code} -ppr_casm_results - :: [CAddrMode] -- list of results (length <= 1) - -> Bool -- True => multiple results OK. - -> - ( SDoc, -- declaration of any local vars - [SDoc], -- list of result vars (same length as results) - SDoc ) -- assignment (if any) of results in local var to registers - -ppr_casm_results [] _ - = (empty, [], empty) -- no results - -ppr_casm_results (r:rs) multiResultsOK - | not multiResultsOK && not (null rs) = panic "ppr_casm_results: ccall/casm with many results" - | otherwise - = foldr (\ (a,b,c) (as,bs,cs) -> (a $$ as, b ++ bs, c $$ cs)) - (empty,[],empty) - (zipWith pprRes (r:rs) ("" : map show [(1::Int)..])) - where - pprRes r suf = (declare_local_var, [local_var], assign_result) - where - result_reg = ppr_amode r - r_kind = getAmodeRep r - - local_var = ptext SLIT("_ccall_result") <> text suf - - (result_type, assign_result) - = (pprPrimKind r_kind, - hcat [ result_reg, equals, local_var, semi ]) - - declare_local_var = hcat [ result_type, space, local_var, semi ] - -\end{code} - - -Note the sneaky way _the_ result is represented by a list so that we -can complain if it's used twice. - -ToDo: Any chance of giving line numbers when process-casm fails? - Or maybe we should do a check _much earlier_ in compiler. ADR - -\begin{code} -process_casm :: [SDoc] -- results (length <= 1) - -> [SDoc] -- arguments - -> String -- format string (with embedded %'s) - -> SDoc -- code being generated - -process_casm results args string = process results args string - where - process [] _ "" = empty - process (_:_) _ "" = error ("process_casm: non-void result not assigned while processing _casm_ \"" ++ - string ++ - "\"\n(Try changing result type to IO ()\n") - - process ress args ('%':cs) - = case cs of - [] -> - error ("process_casm: lonely % while processing _casm_ \"" ++ string ++ "\".\n") - - ('%':css) -> - char '%' <> process ress args css - - ('r':css) -> - case ress of - [] -> error ("process_casm: no result to match %r while processing _casm_ \"" ++ string ++ "\".\nTry deleting %r or changing result type from PrimIO ()\n") - [r] -> r <> (process [] args css) - _ -> panic ("process_casm: casm with many results while processing _casm_ \"" ++ string ++ "\".\n") - - other -> - let - read_int :: ReadS Int - read_int = reads - in - case (read_int other) of - [(num,css)] -> - if num >= 0 && args `lengthExceeds` num - then parens (args !! num) <> process ress args css - else error ("process_casm: no such arg #:"++(show num)++" while processing \"" ++ string ++ "\".\n") - _ -> error ("process_casm: not % while processing _casm_ \"" ++ string ++ "\".\n") - - process ress args (other_c:cs) - = char other_c <> process ress args cs -\end{code} - -%************************************************************************ -%* * -\subsection[a2r-assignments]{Assignments} -%* * -%************************************************************************ - -Printing assignments is a little tricky because of type coercion. - -First of all, the kind of the thing being assigned can be gotten from -the destination addressing mode. (It should be the same as the kind -of the source addressing mode.) If the kind of the assignment is of -@VoidRep@, then don't generate any code at all. - -\begin{code} -pprAssign :: PrimRep -> CAddrMode -> CAddrMode -> SDoc - -pprAssign VoidRep dest src = empty -\end{code} - -Special treatment for floats and doubles, to avoid unwanted conversions. - -\begin{code} -pprAssign FloatRep dest@(CVal reg_rel _) src - = hcat [ ptext SLIT("ASSIGN_FLT((W_*)"), parens (ppr_amode (CAddr reg_rel)), comma, pprAmode src, pp_paren_semi ] - -pprAssign DoubleRep dest@(CVal reg_rel _) src - = hcat [ ptext SLIT("ASSIGN_DBL((W_*)"), parens (ppr_amode (CAddr reg_rel)), comma, pprAmode src, pp_paren_semi ] - -pprAssign Int64Rep dest@(CVal reg_rel _) src - = hcat [ ptext SLIT("ASSIGN_Int64((W_*)"), parens (ppr_amode (CAddr reg_rel)), comma, pprAmode src, pp_paren_semi ] -pprAssign Word64Rep dest@(CVal reg_rel _) src - = hcat [ ptext SLIT("ASSIGN_Word64((W_*)"), parens (ppr_amode (CAddr reg_rel)), comma, pprAmode src, pp_paren_semi ] -\end{code} - -Lastly, the question is: will the C compiler think the types of the -two sides of the assignment match? - - We assume that the types will match if neither side is a - @CVal@ addressing mode for any register which can point into - the heap or stack. - -Why? Because the heap and stack are used to store miscellaneous -things, whereas the temporaries, registers, etc., are only used for -things of fixed type. - -\begin{code} -pprAssign kind (CReg (VanillaReg _ dest)) (CReg (VanillaReg _ src)) - = hcat [ pprVanillaReg dest, equals, - pprVanillaReg src, semi ] - -pprAssign kind dest src - | mixedTypeLocn dest - -- Add in a cast to StgWord (a.k.a. W_) iff the destination is mixed - = hcat [ ppr_amode dest, equals, - text "(W_)(", -- Here is the cast - ppr_amode src, pp_paren_semi ] - -pprAssign kind dest src - | mixedPtrLocn dest && getAmodeRep src /= PtrRep - -- Add in a cast to StgPtr (a.k.a. P_) iff the destination is mixed - = hcat [ ppr_amode dest, equals, - text "(P_)(", -- Here is the cast - ppr_amode src, pp_paren_semi ] - -pprAssign kind other_dest src - = hcat [ ppr_amode other_dest, equals, - pprAmode src, semi ] -\end{code} - - -%************************************************************************ -%* * -\subsection[a2r-CAddrModes]{Addressing modes} -%* * -%************************************************************************ - -@pprAmode@ is used to print r-values (which may need casts), whereas -@ppr_amode@ is used for l-values {\em and} as a help function for -@pprAmode@. - -\begin{code} -pprAmode, ppr_amode :: CAddrMode -> SDoc -\end{code} - -For reasons discussed above under assignments, @CVal@ modes need -to be treated carefully. First come special cases for floats and doubles, -similar to those in @pprAssign@: - -(NB: @PK_FLT@ and @PK_DBL@ require the {\em address} of the value in -question.) - -\begin{code} -pprAmode (CVal reg_rel FloatRep) - = hcat [ text "PK_FLT((W_*)", parens (ppr_amode (CAddr reg_rel)), rparen ] -pprAmode (CVal reg_rel DoubleRep) - = hcat [ text "PK_DBL((W_*)", parens (ppr_amode (CAddr reg_rel)), rparen ] -pprAmode (CVal reg_rel Int64Rep) - = hcat [ text "PK_Int64((W_*)", parens (ppr_amode (CAddr reg_rel)), rparen ] -pprAmode (CVal reg_rel Word64Rep) - = hcat [ text "PK_Word64((W_*)", parens (ppr_amode (CAddr reg_rel)), rparen ] -\end{code} - -Next comes the case where there is some other cast need, and the -no-cast case: - -\begin{code} -pprAmode amode - | mixedTypeLocn amode - = parens (hcat [ pprPrimKind (getAmodeRep amode), ptext SLIT(")("), - ppr_amode amode ]) - | otherwise -- No cast needed - = ppr_amode amode -\end{code} - -When we have an indirection through a CIndex, we have to be careful to -get the type casts right. - -this amode: - - CVal (CIndex kind1 base offset) kind2 - -means (in C speak): - - *(kind2 *)((kind1 *)base + offset) - -That is, the indexing is done in units of kind1, but the resulting -amode has kind2. - -\begin{code} -ppr_amode (CVal reg_rel@(CIndex _ _ _) kind) - = case (pprRegRelative False{-no sign wanted-} reg_rel) of - (pp_reg, Nothing) -> panic "ppr_amode: CIndex" - (pp_reg, Just offset) -> - hcat [ char '*', parens (pprPrimKind kind <> char '*'), - parens (pp_reg <> char '+' <> offset) ] -\end{code} - -Now the rest of the cases for ``workhorse'' @ppr_amode@: - -\begin{code} -ppr_amode (CVal reg_rel _) - = case (pprRegRelative False{-no sign wanted-} reg_rel) of - (pp_reg, Nothing) -> (<>) (char '*') pp_reg - (pp_reg, Just offset) -> hcat [ pp_reg, brackets offset ] - -ppr_amode (CAddr reg_rel) - = case (pprRegRelative True{-sign wanted-} reg_rel) of - (pp_reg, Nothing) -> pp_reg - (pp_reg, Just offset) -> pp_reg <> offset - -ppr_amode (CReg magic_id) = pprMagicId magic_id - -ppr_amode (CTemp uniq kind) = char '_' <> pprUnique uniq <> char '_' - -ppr_amode (CLbl lbl kind) = pprCLabelAddr lbl - -ppr_amode (CCharLike ch) - = hcat [ptext SLIT("CHARLIKE_CLOSURE"), char '(', pprAmode ch, rparen ] -ppr_amode (CIntLike int) - = hcat [ptext SLIT("INTLIKE_CLOSURE"), char '(', pprAmode int, rparen ] - -ppr_amode (CLit lit) = pprBasicLit lit - -ppr_amode (CJoinPoint _) - = panic "ppr_amode: CJoinPoint" - -ppr_amode (CMacroExpr pk macro as) - = parens (ptext (cExprMacroText macro) <> - parens (hcat (punctuate comma (map pprAmode as)))) -\end{code} - -\begin{code} -cExprMacroText ENTRY_CODE = SLIT("ENTRY_CODE") -cExprMacroText ARG_TAG = SLIT("ARG_TAG") -cExprMacroText GET_TAG = SLIT("GET_TAG") -cExprMacroText CCS_HDR = SLIT("CCS_HDR") -cExprMacroText BYTE_ARR_CTS = SLIT("BYTE_ARR_CTS") -cExprMacroText PTRS_ARR_CTS = SLIT("PTRS_ARR_CTS") -cExprMacroText ForeignObj_CLOSURE_DATA = SLIT("ForeignObj_CLOSURE_DATA") - -cStmtMacroText UPD_CAF = SLIT("UPD_CAF") -cStmtMacroText UPD_BH_UPDATABLE = SLIT("UPD_BH_UPDATABLE") -cStmtMacroText UPD_BH_SINGLE_ENTRY = SLIT("UPD_BH_SINGLE_ENTRY") -cStmtMacroText PUSH_UPD_FRAME = SLIT("PUSH_UPD_FRAME") -cStmtMacroText SET_TAG = SLIT("SET_TAG") -cStmtMacroText DATA_TO_TAGZH = SLIT("dataToTagzh") -cStmtMacroText REGISTER_FOREIGN_EXPORT = SLIT("REGISTER_FOREIGN_EXPORT") -cStmtMacroText REGISTER_IMPORT = SLIT("REGISTER_IMPORT") -cStmtMacroText REGISTER_DIMPORT = SLIT("REGISTER_DIMPORT") -cStmtMacroText GRAN_FETCH = SLIT("GRAN_FETCH") -cStmtMacroText GRAN_RESCHEDULE = SLIT("GRAN_RESCHEDULE") -cStmtMacroText GRAN_FETCH_AND_RESCHEDULE= SLIT("GRAN_FETCH_AND_RESCHEDULE") -cStmtMacroText THREAD_CONTEXT_SWITCH = SLIT("THREAD_CONTEXT_SWITCH") -cStmtMacroText GRAN_YIELD = SLIT("GRAN_YIELD") - -cCheckMacroText HP_CHK_NP = SLIT("HP_CHK_NP") -cCheckMacroText STK_CHK_NP = SLIT("STK_CHK_NP") -cCheckMacroText HP_STK_CHK_NP = SLIT("HP_STK_CHK_NP") -cCheckMacroText HP_CHK_FUN = SLIT("HP_CHK_FUN") -cCheckMacroText STK_CHK_FUN = SLIT("STK_CHK_FUN") -cCheckMacroText HP_STK_CHK_FUN = SLIT("HP_STK_CHK_FUN") -cCheckMacroText HP_CHK_NOREGS = SLIT("HP_CHK_NOREGS") -cCheckMacroText HP_CHK_UNPT_R1 = SLIT("HP_CHK_UNPT_R1") -cCheckMacroText HP_CHK_UNBX_R1 = SLIT("HP_CHK_UNBX_R1") -cCheckMacroText HP_CHK_F1 = SLIT("HP_CHK_F1") -cCheckMacroText HP_CHK_D1 = SLIT("HP_CHK_D1") -cCheckMacroText HP_CHK_L1 = SLIT("HP_CHK_L1") -cCheckMacroText HP_CHK_UNBX_TUPLE = SLIT("HP_CHK_UNBX_TUPLE") -\end{code} - -%************************************************************************ -%* * -\subsection[ppr-liveness-masks]{Liveness Masks} -%* * -%************************************************************************ - -\begin{code} -bitmapAddrModes [] = [mkWordCLit 0] -bitmapAddrModes xs = map mkWordCLit xs -\end{code} - -%************************************************************************ -%* * -\subsection[a2r-MagicIds]{Magic ids} -%* * -%************************************************************************ - -@pprRegRelative@ returns a pair of the @Doc@ for the register -(some casting may be required), and a @Maybe Doc@ for the offset -(zero offset gives a @Nothing@). - -\begin{code} -addPlusSign :: Bool -> SDoc -> SDoc -addPlusSign False p = p -addPlusSign True p = (<>) (char '+') p - -pprSignedInt :: Bool -> Int -> Maybe SDoc -- Nothing => 0 -pprSignedInt sign_wanted n - = if n == 0 then Nothing else - if n > 0 then Just (addPlusSign sign_wanted (int n)) - else Just (int n) - -pprRegRelative :: Bool -- True <=> Print leading plus sign (if +ve) - -> RegRelative - -> (SDoc, Maybe SDoc) - -pprRegRelative sign_wanted (SpRel off) - = (pprMagicId Sp, pprSignedInt sign_wanted (I# off)) - -pprRegRelative sign_wanted r@(HpRel o) - = let pp_Hp = pprMagicId Hp; off = I# o - in - if off == 0 then - (pp_Hp, Nothing) - else - (pp_Hp, Just ((<>) (char '-') (int off))) - -pprRegRelative sign_wanted (NodeRel o) - = let pp_Node = pprMagicId node; off = I# o - in - if off == 0 then - (pp_Node, Nothing) - else - (pp_Node, Just (addPlusSign sign_wanted (int off))) - -pprRegRelative sign_wanted (CIndex base offset kind) - = ( hcat [text "((", pprPrimKind kind, text " *)(", ppr_amode base, text "))"] - , Just (hcat [if sign_wanted then char '+' else empty, - text "(I_)(", ppr_amode offset, ptext SLIT(")")]) - ) -\end{code} - -@pprMagicId@ just prints the register name. @VanillaReg@ registers are -represented by a discriminated union (@StgUnion@), so we use the @PrimRep@ -to select the union tag. - -\begin{code} -pprMagicId :: MagicId -> SDoc - -pprMagicId BaseReg = ptext SLIT("BaseReg") -pprMagicId (VanillaReg pk n) - = hcat [ pprVanillaReg n, char '.', - pprUnionTag pk ] -pprMagicId (FloatReg n) = ptext SLIT("F") <> int (I# n) -pprMagicId (DoubleReg n) = ptext SLIT("D") <> int (I# n) -pprMagicId (LongReg _ n) = ptext SLIT("L") <> int (I# n) -pprMagicId Sp = ptext SLIT("Sp") -pprMagicId SpLim = ptext SLIT("SpLim") -pprMagicId Hp = ptext SLIT("Hp") -pprMagicId HpLim = ptext SLIT("HpLim") -pprMagicId CurCostCentre = ptext SLIT("CCCS") -pprMagicId VoidReg = ptext SLIT("VoidReg") - -pprVanillaReg :: Int# -> SDoc -pprVanillaReg n = char 'R' <> int (I# n) - -pprUnionTag :: PrimRep -> SDoc - -pprUnionTag PtrRep = char 'p' -pprUnionTag CodePtrRep = ptext SLIT("fp") -pprUnionTag DataPtrRep = char 'd' -pprUnionTag RetRep = char 'p' -pprUnionTag CostCentreRep = panic "pprUnionTag:CostCentre?" - -pprUnionTag CharRep = char 'c' -pprUnionTag Int8Rep = ptext SLIT("i8") -pprUnionTag IntRep = char 'i' -pprUnionTag WordRep = char 'w' -pprUnionTag Int32Rep = char 'i' -pprUnionTag Word32Rep = char 'w' -pprUnionTag AddrRep = char 'a' -pprUnionTag FloatRep = char 'f' -pprUnionTag DoubleRep = panic "pprUnionTag:Double?" - -pprUnionTag StablePtrRep = char 'p' - -pprUnionTag _ = panic "pprUnionTag:Odd kind" -\end{code} - - -Find and print local and external declarations for a list of -Abstract~C statements. -\begin{code} -pprTempAndExternDecls :: AbstractC -> (SDoc{-temps-}, SDoc{-externs-}) -pprTempAndExternDecls AbsCNop = (empty, empty) - -pprTempAndExternDecls (AbsCStmts stmt1 stmt2) - = initTE (ppr_decls_AbsC stmt1 `thenTE` \ (t_p1, e_p1) -> - ppr_decls_AbsC stmt2 `thenTE` \ (t_p2, e_p2) -> - case (catMaybes [t_p1, t_p2]) of { real_temps -> - case (catMaybes [e_p1, e_p2]) of { real_exts -> - returnTE (vcat real_temps, vcat real_exts) }} - ) - -pprTempAndExternDecls other_stmt - = initTE (ppr_decls_AbsC other_stmt `thenTE` \ (maybe_t, maybe_e) -> - returnTE ( - case maybe_t of - Nothing -> empty - Just pp -> pp, - - case maybe_e of - Nothing -> empty - Just pp -> pp ) - ) - -pprBasicLit :: Literal -> SDoc -pprPrimKind :: PrimRep -> SDoc - -pprBasicLit lit = ppr lit -pprPrimKind k = ppr k -\end{code} - - -%************************************************************************ -%* * -\subsection[a2r-monad]{Monadery} -%* * -%************************************************************************ - -We need some monadery to keep track of temps and externs we have already -printed. This info must be threaded right through the Abstract~C, so -it's most convenient to hide it in this monad. - -WDP 95/02: Switched from \tr{([Unique], [CLabel])} to -\tr{(UniqSet, CLabelSet)}. Allegedly for efficiency. - -\begin{code} -type CLabelSet = FiniteMap CLabel (){-any type will do-} -emptyCLabelSet = emptyFM -x `elementOfCLabelSet` labs - = case (lookupFM labs x) of { Just _ -> True; Nothing -> False } - -addToCLabelSet set x = addToFM set x () - -type TEenv = (UniqSet Unique, CLabelSet) - -type TeM result = TEenv -> (TEenv, result) - -initTE :: TeM a -> a -initTE sa - = case sa (emptyUniqSet, emptyCLabelSet) of { (_, result) -> - result } - -{-# INLINE thenTE #-} -{-# INLINE returnTE #-} - -thenTE :: TeM a -> (a -> TeM b) -> TeM b -thenTE a b u - = case a u of { (u_1, result_of_a) -> - b result_of_a u_1 } - -mapTE :: (a -> TeM b) -> [a] -> TeM [b] -mapTE f [] = returnTE [] -mapTE f (x:xs) - = f x `thenTE` \ r -> - mapTE f xs `thenTE` \ rs -> - returnTE (r : rs) - -returnTE :: a -> TeM a -returnTE result env = (env, result) - --- these next two check whether the thing is already --- recorded, and THEN THEY RECORD IT --- (subsequent calls will return False for the same uniq/label) - -tempSeenTE :: Unique -> TeM Bool -tempSeenTE uniq env@(seen_uniqs, seen_labels) - = if (uniq `elementOfUniqSet` seen_uniqs) - then (env, True) - else ((addOneToUniqSet seen_uniqs uniq, - seen_labels), - False) - -labelSeenTE :: CLabel -> TeM Bool -labelSeenTE lbl env@(seen_uniqs, seen_labels) - = if (lbl `elementOfCLabelSet` seen_labels) - then (env, True) - else ((seen_uniqs, - addToCLabelSet seen_labels lbl), - False) -\end{code} - -\begin{code} -pprTempDecl :: Unique -> PrimRep -> SDoc -pprTempDecl uniq kind - = hcat [ pprPrimKind kind, space, char '_', pprUnique uniq, ptext SLIT("_;") ] - -pprExternDecl :: Bool -> CLabel -> SDoc -pprExternDecl in_srt clabel - | not (needsCDecl clabel) = empty -- do not print anything for "known external" things - | otherwise = - hcat [ ppLocalnessMacro (not in_srt) clabel, - lparen, dyn_wrapper (pprCLabel clabel), pp_paren_semi ] - where - dyn_wrapper d - | in_srt && labelDynamic clabel = text "DLL_IMPORT_DATA_VAR" <> parens d - | otherwise = d - -\end{code} - -\begin{code} -ppr_decls_AbsC :: AbstractC -> TeM (Maybe SDoc{-temps-}, Maybe SDoc{-externs-}) - -ppr_decls_AbsC AbsCNop = returnTE (Nothing, Nothing) - -ppr_decls_AbsC (AbsCStmts stmts_1 stmts_2) - = ppr_decls_AbsC stmts_1 `thenTE` \ p1 -> - ppr_decls_AbsC stmts_2 `thenTE` \ p2 -> - returnTE (maybe_vcat [p1, p2]) - -ppr_decls_AbsC (CSplitMarker) = returnTE (Nothing, Nothing) - -ppr_decls_AbsC (CAssign dest source) - = ppr_decls_Amode dest `thenTE` \ p1 -> - ppr_decls_Amode source `thenTE` \ p2 -> - returnTE (maybe_vcat [p1, p2]) - -ppr_decls_AbsC (CJump target) = ppr_decls_Amode target - -ppr_decls_AbsC (CFallThrough target) = ppr_decls_Amode target - -ppr_decls_AbsC (CReturn target _) = ppr_decls_Amode target - -ppr_decls_AbsC (CSwitch discrim alts deflt) - = ppr_decls_Amode discrim `thenTE` \ pdisc -> - mapTE ppr_alt_stuff alts `thenTE` \ palts -> - ppr_decls_AbsC deflt `thenTE` \ pdeflt -> - returnTE (maybe_vcat (pdisc:pdeflt:palts)) - where - ppr_alt_stuff (_, absC) = ppr_decls_AbsC absC - -ppr_decls_AbsC (CCodeBlock lbl absC) - = ppr_decls_AbsC absC - -ppr_decls_AbsC (CInitHdr cl_info reg_rel cost_centre _) - -- ToDo: strictly speaking, should chk "cost_centre" amode - = labelSeenTE info_lbl `thenTE` \ label_seen -> - returnTE (Nothing, - if label_seen then - Nothing - else - Just (pprExternDecl False{-not in an SRT decl-} info_lbl)) - where - info_lbl = infoTableLabelFromCI cl_info - -ppr_decls_AbsC (CMachOpStmt res _ args _) = ppr_decls_Amodes (res : args) -ppr_decls_AbsC (COpStmt results _ args _) = ppr_decls_Amodes (results ++ args) - -ppr_decls_AbsC (CSimultaneous abc) = ppr_decls_AbsC abc - -ppr_decls_AbsC (CSequential abcs) - = mapTE ppr_decls_AbsC abcs `thenTE` \ t_and_e_s -> - returnTE (maybe_vcat t_and_e_s) - -ppr_decls_AbsC (CCheck _ amodes code) = - ppr_decls_Amodes amodes `thenTE` \p1 -> - ppr_decls_AbsC code `thenTE` \p2 -> - returnTE (maybe_vcat [p1,p2]) - -ppr_decls_AbsC (CMacroStmt _ amodes) = ppr_decls_Amodes amodes - -ppr_decls_AbsC (CCallProfCtrMacro _ amodes) = ppr_decls_Amodes [] -- *****!!! - -- you get some nasty re-decls of stdio.h if you compile - -- the prelude while looking inside those amodes; - -- no real reason to, anyway. -ppr_decls_AbsC (CCallProfCCMacro _ amodes) = ppr_decls_Amodes amodes - -ppr_decls_AbsC (CStaticClosure _ closure_info cost_centre amodes) - -- ToDo: strictly speaking, should chk "cost_centre" amode - = ppr_decls_Amodes amodes - -ppr_decls_AbsC (CClosureInfoAndCode cl_info entry) - = ppr_decls_Amodes [entry_lbl] `thenTE` \ p1 -> - ppr_decls_AbsC entry `thenTE` \ p2 -> - returnTE (maybe_vcat [p1, p2]) - where - entry_lbl = CLbl (entryLabelFromCI cl_info) CodePtrRep - -ppr_decls_AbsC (CSRT _ closure_lbls) - = mapTE labelSeenTE closure_lbls `thenTE` \ seen -> - returnTE (Nothing, - if and seen then Nothing - else Just (vcat [ pprExternDecl True{-in SRT decl-} l - | (l,False) <- zip closure_lbls seen ])) - -ppr_decls_AbsC (CRetDirect _ code _ _) = ppr_decls_AbsC code -ppr_decls_AbsC (CRetVector _ amodes _ _) = ppr_decls_Amodes amodes -ppr_decls_AbsC (CModuleInitBlock _ _ code) = ppr_decls_AbsC code - -ppr_decls_AbsC (_) = returnTE (Nothing, Nothing) -\end{code} - -\begin{code} -ppr_decls_Amode :: CAddrMode -> TeM (Maybe SDoc, Maybe SDoc) -ppr_decls_Amode (CVal (CIndex base offset _) _) = ppr_decls_Amodes [base,offset] -ppr_decls_Amode (CAddr (CIndex base offset _)) = ppr_decls_Amodes [base,offset] -ppr_decls_Amode (CVal _ _) = returnTE (Nothing, Nothing) -ppr_decls_Amode (CAddr _) = returnTE (Nothing, Nothing) -ppr_decls_Amode (CReg _) = returnTE (Nothing, Nothing) -ppr_decls_Amode (CLit _) = returnTE (Nothing, Nothing) - --- CIntLike must be a literal -- no decls -ppr_decls_Amode (CIntLike int) = returnTE (Nothing, Nothing) - --- CCharLike too -ppr_decls_Amode (CCharLike char) = returnTE (Nothing, Nothing) - --- now, the only place where we actually print temps/externs... -ppr_decls_Amode (CTemp uniq kind) - = case kind of - VoidRep -> returnTE (Nothing, Nothing) - other -> - tempSeenTE uniq `thenTE` \ temp_seen -> - returnTE - (if temp_seen then Nothing else Just (pprTempDecl uniq kind), Nothing) - -ppr_decls_Amode (CLbl lbl VoidRep) - = returnTE (Nothing, Nothing) - -ppr_decls_Amode (CLbl lbl kind) - = labelSeenTE lbl `thenTE` \ label_seen -> - returnTE (Nothing, - if label_seen then Nothing else Just (pprExternDecl False{-not in an SRT decl-} lbl)) - -ppr_decls_Amode (CMacroExpr _ _ amodes) - = ppr_decls_Amodes amodes - -ppr_decls_Amode other = returnTE (Nothing, Nothing) - - -maybe_vcat :: [(Maybe SDoc, Maybe SDoc)] -> (Maybe SDoc, Maybe SDoc) -maybe_vcat ps - = case (unzip ps) of { (ts, es) -> - case (catMaybes ts) of { real_ts -> - case (catMaybes es) of { real_es -> - (if (null real_ts) then Nothing else Just (vcat real_ts), - if (null real_es) then Nothing else Just (vcat real_es)) - } } } -\end{code} - -\begin{code} -ppr_decls_Amodes :: [CAddrMode] -> TeM (Maybe SDoc, Maybe SDoc) -ppr_decls_Amodes amodes - = mapTE ppr_decls_Amode amodes `thenTE` \ ps -> - returnTE ( maybe_vcat ps ) -\end{code} - -Print out a C Label where you want the *address* of the label, not the -object it refers to. The distinction is important when the label may -refer to a C structure (info tables and closures, for instance). - -When just generating a declaration for the label, use pprCLabel. - -\begin{code} -pprCLabelAddr :: CLabel -> SDoc -pprCLabelAddr clabel = - case labelType clabel of - InfoTblType -> addr_of_label - RetInfoTblType -> addr_of_label - ClosureType -> addr_of_label - VecTblType -> addr_of_label - DataType -> addr_of_label - - _ -> pp_label - where - addr_of_label = ptext SLIT("(P_)&") <> pp_label - pp_label = pprCLabel clabel -\end{code} - ------------------------------------------------------------------------------ -Initialising static objects with floating-point numbers. We can't -just emit the floating point number, because C will cast it to an int -by rounding it. We want the actual bit-representation of the float. - -This is a hack to turn the floating point numbers into ints that we -can safely initialise to static locations. - -\begin{code} -big_doubles = (getPrimRepSize DoubleRep) /= 1 - -#if __GLASGOW_HASKELL__ >= 504 -newFloatArray :: (Int,Int) -> ST s (STUArray s Int Float) -newFloatArray = newArray_ - -newDoubleArray :: (Int,Int) -> ST s (STUArray s Int Double) -newDoubleArray = newArray_ - -castFloatToIntArray :: STUArray s Int Float -> ST s (STUArray s Int Int) -castFloatToIntArray = castSTUArray - -castDoubleToIntArray :: STUArray s Int Double -> ST s (STUArray s Int Int) -castDoubleToIntArray = castSTUArray - -writeFloatArray :: STUArray s Int Float -> Int -> Float -> ST s () -writeFloatArray = writeArray - -writeDoubleArray :: STUArray s Int Double -> Int -> Double -> ST s () -writeDoubleArray = writeArray - -readIntArray :: STUArray s Int Int -> Int -> ST s Int -readIntArray = readArray - -#else - -castFloatToIntArray :: MutableByteArray s t -> ST s (MutableByteArray s t) -castFloatToIntArray = return - -castDoubleToIntArray :: MutableByteArray s t -> ST s (MutableByteArray s t) -castDoubleToIntArray = return - -#endif - --- floats are always 1 word -floatToWord :: CAddrMode -> CAddrMode -floatToWord (CLit (MachFloat r)) - = runST (do - arr <- newFloatArray ((0::Int),0) - writeFloatArray arr 0 (fromRational r) - arr' <- castFloatToIntArray arr - i <- readIntArray arr' 0 - return (CLit (MachInt (toInteger i))) - ) - -doubleToWords :: CAddrMode -> [CAddrMode] -doubleToWords (CLit (MachDouble r)) - | big_doubles -- doubles are 2 words - = runST (do - arr <- newDoubleArray ((0::Int),1) - writeDoubleArray arr 0 (fromRational r) - arr' <- castDoubleToIntArray arr - i1 <- readIntArray arr' 0 - i2 <- readIntArray arr' 1 - return [ CLit (MachInt (toInteger i1)) - , CLit (MachInt (toInteger i2)) - ] - ) - | otherwise -- doubles are 1 word - = runST (do - arr <- newDoubleArray ((0::Int),0) - writeDoubleArray arr 0 (fromRational r) - arr' <- castDoubleToIntArray arr - i <- readIntArray arr' 0 - return [ CLit (MachInt (toInteger i)) ] - ) -\end{code} diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 87617629c1..4b7f131634 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -15,7 +15,7 @@ module Id ( -- Taking an Id apart idName, idType, idUnique, idInfo, - idPrimRep, isId, globalIdDetails, + isId, globalIdDetails, idPrimRep, recordSelectorFieldLabel, -- Modifying an Id @@ -90,7 +90,8 @@ import Var ( Id, DictId, globalIdDetails ) import qualified Var ( mkLocalId, mkGlobalId, mkSpecPragmaId, mkExportedLocalId ) -import Type ( Type, typePrimRep, addFreeTyVars, seqType, splitTyConApp_maybe ) +import Type ( Type, typePrimRep, addFreeTyVars, seqType, + splitTyConApp_maybe, PrimRep ) import TysPrim ( statePrimTyCon ) import IdInfo @@ -105,7 +106,6 @@ import Name ( Name, OccName, nameIsLocalOrFrom, ) import Module ( Module ) import OccName ( EncodedFS, mkWorkerOcc ) -import PrimRep ( PrimRep ) import FieldLabel ( FieldLabel ) import Maybes ( orElse ) import SrcLoc ( SrcLoc ) diff --git a/ghc/compiler/basicTypes/Literal.lhs b/ghc/compiler/basicTypes/Literal.lhs index 35d9ba0fea..01b21b12ee 100644 --- a/ghc/compiler/basicTypes/Literal.lhs +++ b/ghc/compiler/basicTypes/Literal.lhs @@ -10,7 +10,7 @@ module Literal , mkMachInt64, mkMachWord64 , litSize , litIsDupable, litIsTrivial - , literalType, literalPrimRep + , literalType, , hashLiteral , inIntRange, inWordRange, tARGET_MAX_INT, inCharRange @@ -29,10 +29,7 @@ module Literal import TysPrim ( charPrimTy, addrPrimTy, floatPrimTy, doublePrimTy, intPrimTy, wordPrimTy, int64PrimTy, word64PrimTy ) -import PrimRep ( PrimRep(..) ) import Type ( Type ) -import CStrings ( pprFSInCStyle ) - import Outputable import FastTypes import FastString @@ -298,31 +295,16 @@ litSize _other = 1 ~~~~~ \begin{code} literalType :: Literal -> Type -literalType (MachChar _) = charPrimTy -literalType (MachStr _) = addrPrimTy -literalType (MachNullAddr) = addrPrimTy -literalType (MachInt _) = intPrimTy -literalType (MachWord _) = wordPrimTy -literalType (MachInt64 _) = int64PrimTy -literalType (MachWord64 _) = word64PrimTy -literalType (MachFloat _) = floatPrimTy -literalType (MachDouble _) = doublePrimTy -literalType (MachLabel _ _) = addrPrimTy -\end{code} - -\begin{code} -literalPrimRep :: Literal -> PrimRep - -literalPrimRep (MachChar _) = CharRep -literalPrimRep (MachStr _) = AddrRep -- specifically: "char *" -literalPrimRep (MachNullAddr) = AddrRep -literalPrimRep (MachInt _) = IntRep -literalPrimRep (MachWord _) = WordRep -literalPrimRep (MachInt64 _) = Int64Rep -literalPrimRep (MachWord64 _) = Word64Rep -literalPrimRep (MachFloat _) = FloatRep -literalPrimRep (MachDouble _) = DoubleRep -literalPrimRep (MachLabel _ _) = AddrRep +literalType MachNullAddr = addrPrimTy +literalType (MachChar _) = charPrimTy +literalType (MachStr _) = addrPrimTy +literalType (MachInt _) = intPrimTy +literalType (MachWord _) = wordPrimTy +literalType (MachInt64 _) = int64PrimTy +literalType (MachWord64 _) = word64PrimTy +literalType (MachFloat _) = floatPrimTy +literalType (MachDouble _) = doublePrimTy +literalType (MachLabel _ _) = addrPrimTy \end{code} @@ -360,71 +342,24 @@ litTag (MachLabel _ _) = _ILIT(10) exceptions: MachFloat gets an initial keyword prefix. \begin{code} -pprLit lit - = getPprStyle $ \ sty -> - let - code_style = codeStyle sty - in - case lit of - MachChar ch | code_style -> hcat [ptext SLIT("(C_)"), text (show (ord ch))] - | otherwise -> pprHsChar ch - - MachStr s | code_style -> pprFSInCStyle s - | otherwise -> pprHsString s - -- Warning: printing MachStr in code_style assumes it contains - -- only characters '\0'..'\xFF'! - - MachInt i | code_style && i == tARGET_MIN_INT -> parens (integer (i+1) <> text "-1") - -- Avoid a problem whereby gcc interprets - -- the constant minInt as unsigned. - | otherwise -> pprIntVal i - - MachInt64 i | code_style -> pprIntVal i -- Same problem with gcc??? - | otherwise -> ptext SLIT("__int64") <+> integer i - - MachWord w | code_style -> pprHexVal w - | otherwise -> ptext SLIT("__word") <+> integer w - - MachWord64 w | code_style -> pprHexVal w - | otherwise -> ptext SLIT("__word64") <+> integer w - - MachFloat f | code_style -> ptext SLIT("(StgFloat)") <> code_rational f - | otherwise -> ptext SLIT("__float") <+> rational f - - MachDouble d | code_style -> code_rational d - | otherwise -> rational d - - MachNullAddr | code_style -> ptext SLIT("(void*)0") - | otherwise -> ptext SLIT("__NULL") - - MachLabel l mb - | code_style -> ptext SLIT("(&") <> ftext l <> char ')' - | otherwise -> ptext SLIT("__label") <+> - case mb of - Nothing -> pprHsString l - Just x -> doubleQuotes (text (unpackFS l ++ '@':show x)) - --- negative floating literals in code style need parentheses to avoid --- interacting with surrounding syntax. -code_rational d | d < 0 = parens (rational d) - | otherwise = rational d +pprLit (MachChar ch) = pprHsChar ch +pprLit (MachStr s) = pprHsString s +pprLit (MachInt i) = pprIntVal i +pprLit (MachInt64 i) = ptext SLIT("__int64") <+> integer i +pprLit (MachWord w) = ptext SLIT("__word") <+> integer w +pprLit (MachWord64 w) = ptext SLIT("__word64") <+> integer w +pprLit (MachFloat f) = ptext SLIT("__float") <+> rational f +pprLit (MachDouble d) = rational d +pprLit (MachNullAddr) = ptext SLIT("__NULL") +pprLit (MachLabel l mb) = ptext SLIT("__label") <+> + case mb of + Nothing -> pprHsString l + Just x -> doubleQuotes (text (unpackFS l ++ '@':show x)) pprIntVal :: Integer -> SDoc -- Print negative integers with parens to be sure it's unambiguous pprIntVal i | i < 0 = parens (integer i) | otherwise = integer i - -pprHexVal :: Integer -> SDoc --- Print in C hex format: 0x13fa -pprHexVal 0 = ptext SLIT("0x0") -pprHexVal w = ptext SLIT("0x") <> go w - where - go 0 = empty - go w = go quot <> dig - where - (quot,rem) = w `quotRem` 16 - dig | rem < 10 = char (chr (fromInteger rem + ord '0')) - | otherwise = char (chr (fromInteger rem - 10 + ord 'a')) \end{code} diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index 2b55d01639..702b07ff15 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -323,9 +323,7 @@ pprExternal sty name uniq mod occ mb_p is_wired pprInternal sty uniq occ | codeStyle sty = pprUnique uniq - | debugStyle sty = hsep [pprOccName occ, text "{-", - text (briefOccNameFlavour occ), - pprUnique uniq, text "-}"] + | debugStyle sty = pprOccName occ <> text "{-" <> pprUnique uniq <> text "-}" | otherwise = pprOccName occ -- User style -- Like Internal, except that we only omit the unique in Iface style diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs index 9f5109f627..dbfc12a865 100644 --- a/ghc/compiler/basicTypes/Unique.lhs +++ b/ghc/compiler/basicTypes/Unique.lhs @@ -41,7 +41,10 @@ module Unique ( mkPArrDataConUnique, mkBuiltinUnique, - mkPseudoUnique3 + mkPseudoUniqueC, + mkPseudoUniqueD, + mkPseudoUniqueE, + mkPseudoUniqueH ) where #include "HsVersions.h" @@ -255,13 +258,22 @@ iToBase62 n@(I# n#) Allocation of unique supply characters: v,t,u : for renumbering value-, type- and usage- vars. - other a-z: lower case chars for unique supplies (see Main.lhs) B: builtin C-E: pseudo uniques (used in native-code generator) X: uniques derived by deriveUnique _: unifiable tyvars (above) 0-9: prelude things below + other a-z: lower case chars for unique supplies. Used so far: + + d desugarer + f AbsC flattener + g SimplStg + l ndpFlatten + n Native codegen + r Hsc name cache + s simplifier + \begin{code} mkAlphaTyVarUnique i = mkUnique '1' i @@ -303,15 +315,13 @@ mkPArrDataConUnique a = mkUnique ':' (2*a) initTyVarUnique :: Unique initTyVarUnique = mkUnique 't' 0 -mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3, +mkPseudoUniqueC, mkPseudoUniqueD, mkPseudoUniqueE, mkPseudoUniqueH, mkBuiltinUnique :: Int -> Unique -builtinUniques :: [Unique] -builtinUniques = map mkBuiltinUnique [1..] - mkBuiltinUnique i = mkUnique 'B' i -mkPseudoUnique1 i = mkUnique 'C' i -- used for getUnique on Regs -mkPseudoUnique2 i = mkUnique 'D' i -- used in NCG for getUnique on RealRegs -mkPseudoUnique3 i = mkUnique 'E' i -- used in NCG spiller to create spill VirtualRegs +mkPseudoUniqueC i = mkUnique 'C' i -- used for getUnique on Regs +mkPseudoUniqueD i = mkUnique 'D' i -- used in NCG for getUnique on RealRegs +mkPseudoUniqueE i = mkUnique 'E' i -- used in NCG spiller to create spill VirtualRegs +mkPseudoUniqueH i = mkUnique 'H' i -- used in NCG spiller to create spill VirtualRegs \end{code} diff --git a/ghc/compiler/cmm/CLabel.hs b/ghc/compiler/cmm/CLabel.hs new file mode 100644 index 0000000000..ae470caa84 --- /dev/null +++ b/ghc/compiler/cmm/CLabel.hs @@ -0,0 +1,671 @@ +----------------------------------------------------------------------------- +-- +-- Object-file symbols (called CLabel for histerical raisins). +-- +-- (c) The University of Glasgow 2004 +-- +----------------------------------------------------------------------------- + +module CLabel ( + CLabel, -- abstract type + + mkClosureLabel, + mkSRTLabel, + mkSRTDescLabel, + mkInfoTableLabel, + mkEntryLabel, + mkSlowEntryLabel, + mkConEntryLabel, + mkStaticConEntryLabel, + mkRednCountsLabel, + mkConInfoTableLabel, + mkStaticInfoTableLabel, + mkApEntryLabel, + mkApInfoTableLabel, + + mkReturnPtLabel, + mkReturnInfoLabel, + mkAltLabel, + mkDefaultLabel, + mkBitmapLabel, + + mkClosureTblLabel, + + mkAsmTempLabel, + + mkModuleInitLabel, + mkPlainModuleInitLabel, + + mkErrorStdEntryLabel, + mkSplitMarkerLabel, + mkUpdInfoLabel, + mkSeqInfoLabel, + mkIndStaticInfoLabel, + mkMainCapabilityLabel, + mkMAP_FROZEN_infoLabel, + mkEMPTY_MVAR_infoLabel, + + mkTopTickyCtrLabel, + mkCAFBlackHoleInfoTableLabel, + mkSECAFBlackHoleInfoTableLabel, + mkRtsPrimOpLabel, + mkRtsSlowTickyCtrLabel, + + moduleRegdLabel, + + mkSelectorInfoLabel, + mkSelectorEntryLabel, + + mkRtsInfoLabel, + mkRtsEntryLabel, + mkRtsRetInfoLabel, + mkRtsRetLabel, + mkRtsCodeLabel, + mkRtsDataLabel, + + mkRtsInfoLabelFS, + mkRtsEntryLabelFS, + mkRtsRetInfoLabelFS, + mkRtsRetLabelFS, + mkRtsCodeLabelFS, + mkRtsDataLabelFS, + + mkForeignLabel, + + mkCCLabel, mkCCSLabel, + + infoLblToEntryLbl, entryLblToInfoLbl, + needsCDecl, isAsmTemp, externallyVisibleCLabel, + CLabelType(..), labelType, labelDynamic, labelCouldBeDynamic, + + pprCLabel + ) where + + +#include "HsVersions.h" +#include "../includes/ghcconfig.h" + +import CmdLineOpts ( opt_Static, opt_DoTickyProfiling ) +import DataCon ( ConTag ) +import Module ( moduleName, moduleNameFS, + Module, isHomeModule ) +import Name ( Name, isDllName, isExternalName ) +import Unique ( pprUnique, Unique ) +import PrimOp ( PrimOp ) +import Config ( cLeadingUnderscore ) +import CostCentre ( CostCentre, CostCentreStack ) +import Outputable +import FastString + + +-- ----------------------------------------------------------------------------- +-- The CLabel type + +{- +CLabel is an abstract type that supports the following operations: + + - Pretty printing + + - In a C file, does it need to be declared before use? (i.e. is it + guaranteed to be already in scope in the places we need to refer to it?) + + - If it needs to be declared, what type (code or data) should it be + declared to have? + + - Is it visible outside this object file or not? + + - Is it "dynamic" (see details below) + + - Eq and Ord, so that we can make sets of CLabels (currently only + used in outputting C as far as I can tell, to avoid generating + more than one declaration for any given label). + + - Converting an info table label into an entry label. +-} + +data CLabel + = IdLabel -- A family of labels related to the + Name -- definition of a particular Id or Con + IdLabelInfo + + | CaseLabel -- A family of labels related to a particular + -- case expression. + {-# UNPACK #-} !Unique -- Unique says which case expression + CaseLabelInfo + + | AsmTempLabel + {-# UNPACK #-} !Unique + + | ModuleInitLabel + Module -- the module name + String -- its "way" + -- at some point we might want some kind of version number in + -- the module init label, to guard against compiling modules in + -- the wrong order. We can't use the interface file version however, + -- because we don't always recompile modules which depend on a module + -- whose version has changed. + + | PlainModuleInitLabel Module -- without the vesrion & way info + + | ModuleRegdLabel + + | RtsLabel RtsLabelInfo + + | ForeignLabel FastString -- a 'C' (or otherwise foreign) label + (Maybe Int) -- possible '@n' suffix for stdcall functions + -- When generating C, the '@n' suffix is omitted, but when + -- generating assembler we must add it to the label. + Bool -- True <=> is dynamic + + | CC_Label CostCentre + | CCS_Label CostCentreStack + + deriving (Eq, Ord) + + +data IdLabelInfo + = Closure -- Label for closure + | SRT -- Static reference table + | SRTDesc -- Static reference table descriptor + | InfoTbl -- Info tables for closures; always read-only + | Entry -- entry point + | Slow -- slow entry point + + | RednCounts -- Label of place to keep Ticky-ticky info for + -- this Id + + | Bitmap -- A bitmap (function or case return) + + | ConEntry -- constructor entry point + | ConInfoTbl -- corresponding info table + | StaticConEntry -- static constructor entry point + | StaticInfoTbl -- corresponding info table + + | ClosureTable -- table of closures for Enum tycons + + deriving (Eq, Ord) + + +data CaseLabelInfo + = CaseReturnPt + | CaseReturnInfo + | CaseAlt ConTag + | CaseDefault + deriving (Eq, Ord) + + +data RtsLabelInfo + = RtsShouldNeverHappenCode + + | RtsSelectorInfoTbl Bool{-updatable-} Int{-offset-} -- Selector thunks + | RtsSelectorEntry Bool{-updatable-} Int{-offset-} + + | RtsApInfoTbl Bool{-updatable-} Int{-arity-} -- AP thunks + | RtsApEntry Bool{-updatable-} Int{-arity-} + + | RtsPrimOp PrimOp + + | RtsInfo LitString -- misc rts info tables + | RtsEntry LitString -- misc rts entry points + | RtsRetInfo LitString -- misc rts ret info tables + | RtsRet LitString -- misc rts return points + | RtsData LitString -- misc rts data bits, eg CHARLIKE_closure + | RtsCode LitString -- misc rts code + + | RtsInfoFS FastString -- misc rts info tables + | RtsEntryFS FastString -- misc rts entry points + | RtsRetInfoFS FastString -- misc rts ret info tables + | RtsRetFS FastString -- misc rts return points + | RtsDataFS FastString -- misc rts data bits, eg CHARLIKE_closure + | RtsCodeFS FastString -- misc rts code + + | RtsSlowTickyCtr String + + deriving (Eq, Ord) + -- NOTE: Eq on LitString compares the pointer only, so this isn't + -- a real equality. + +-- ----------------------------------------------------------------------------- +-- Constructing CLabels + +mkClosureLabel id = IdLabel id Closure +mkSRTLabel id = IdLabel id SRT +mkSRTDescLabel id = IdLabel id SRTDesc +mkInfoTableLabel id = IdLabel id InfoTbl +mkEntryLabel id = IdLabel id Entry +mkSlowEntryLabel id = IdLabel id Slow +mkBitmapLabel id = IdLabel id Bitmap +mkRednCountsLabel id = IdLabel id RednCounts + +mkConInfoTableLabel con = IdLabel con ConInfoTbl +mkConEntryLabel con = IdLabel con ConEntry +mkStaticInfoTableLabel con = IdLabel con StaticInfoTbl +mkStaticConEntryLabel con = IdLabel con StaticConEntry + +mkClosureTblLabel id = IdLabel id ClosureTable + +mkReturnPtLabel uniq = CaseLabel uniq CaseReturnPt +mkReturnInfoLabel uniq = CaseLabel uniq CaseReturnInfo +mkAltLabel uniq tag = CaseLabel uniq (CaseAlt tag) +mkDefaultLabel uniq = CaseLabel uniq CaseDefault + +mkAsmTempLabel = AsmTempLabel + +mkModuleInitLabel = ModuleInitLabel +mkPlainModuleInitLabel = PlainModuleInitLabel + + -- Some fixed runtime system labels + +mkErrorStdEntryLabel = RtsLabel RtsShouldNeverHappenCode +mkSplitMarkerLabel = RtsLabel (RtsCode SLIT("__stg_split_marker")) +mkUpdInfoLabel = RtsLabel (RtsInfo SLIT("stg_upd_frame")) +mkSeqInfoLabel = RtsLabel (RtsInfo SLIT("stg_seq_frame")) +mkIndStaticInfoLabel = RtsLabel (RtsInfo SLIT("stg_IND_STATIC")) +mkMainCapabilityLabel = RtsLabel (RtsData SLIT("MainCapability")) +mkMAP_FROZEN_infoLabel = RtsLabel (RtsInfo SLIT("stg_MUT_ARR_PTRS_FROZEN")) +mkEMPTY_MVAR_infoLabel = RtsLabel (RtsInfo SLIT("stg_EMPTY_MVAR")) + +mkTopTickyCtrLabel = RtsLabel (RtsData SLIT("top_ct")) +mkCAFBlackHoleInfoTableLabel = RtsLabel (RtsInfo SLIT("stg_CAF_BLACKHOLE")) +mkSECAFBlackHoleInfoTableLabel = if opt_DoTickyProfiling then + RtsLabel (RtsInfo SLIT("stg_SE_CAF_BLACKHOLE")) + else -- RTS won't have info table unless -ticky is on + panic "mkSECAFBlackHoleInfoTableLabel requires -ticky" +mkRtsPrimOpLabel primop = RtsLabel (RtsPrimOp primop) + +moduleRegdLabel = ModuleRegdLabel + +mkSelectorInfoLabel upd off = RtsLabel (RtsSelectorInfoTbl upd off) +mkSelectorEntryLabel upd off = RtsLabel (RtsSelectorEntry upd off) + +mkApInfoTableLabel upd off = RtsLabel (RtsApInfoTbl upd off) +mkApEntryLabel upd off = RtsLabel (RtsApEntry upd off) + + -- Foreign labels + +mkForeignLabel :: FastString -> Maybe Int -> Bool -> CLabel +mkForeignLabel str mb_sz is_dynamic = ForeignLabel str mb_sz is_dynamic + + -- Cost centres etc. + +mkCCLabel cc = CC_Label cc +mkCCSLabel ccs = CCS_Label ccs + +mkRtsInfoLabel str = RtsLabel (RtsInfo str) +mkRtsEntryLabel str = RtsLabel (RtsEntry str) +mkRtsRetInfoLabel str = RtsLabel (RtsRetInfo str) +mkRtsRetLabel str = RtsLabel (RtsRet str) +mkRtsCodeLabel str = RtsLabel (RtsCode str) +mkRtsDataLabel str = RtsLabel (RtsData str) + +mkRtsInfoLabelFS str = RtsLabel (RtsInfoFS str) +mkRtsEntryLabelFS str = RtsLabel (RtsEntryFS str) +mkRtsRetInfoLabelFS str = RtsLabel (RtsRetInfoFS str) +mkRtsRetLabelFS str = RtsLabel (RtsRetFS str) +mkRtsCodeLabelFS str = RtsLabel (RtsCodeFS str) +mkRtsDataLabelFS str = RtsLabel (RtsDataFS str) + +mkRtsSlowTickyCtrLabel :: String -> CLabel +mkRtsSlowTickyCtrLabel pat = RtsLabel (RtsSlowTickyCtr pat) + +-- ----------------------------------------------------------------------------- +-- Converting info labels to entry labels. + +infoLblToEntryLbl :: CLabel -> CLabel +infoLblToEntryLbl (IdLabel n InfoTbl) = IdLabel n Entry +infoLblToEntryLbl (IdLabel n ConInfoTbl) = IdLabel n ConEntry +infoLblToEntryLbl (IdLabel n StaticInfoTbl) = IdLabel n StaticConEntry +infoLblToEntryLbl (CaseLabel n CaseReturnInfo) = CaseLabel n CaseReturnPt +infoLblToEntryLbl (RtsLabel (RtsInfo s)) = RtsLabel (RtsEntry s) +infoLblToEntryLbl (RtsLabel (RtsRetInfo s)) = RtsLabel (RtsRet s) +infoLblToEntryLbl (RtsLabel (RtsInfoFS s)) = RtsLabel (RtsEntryFS s) +infoLblToEntryLbl (RtsLabel (RtsRetInfoFS s)) = RtsLabel (RtsRetFS s) +infoLblToEntryLbl _ = panic "CLabel.infoLblToEntryLbl" + +entryLblToInfoLbl :: CLabel -> CLabel +entryLblToInfoLbl (IdLabel n Entry) = IdLabel n InfoTbl +entryLblToInfoLbl (IdLabel n ConEntry) = IdLabel n ConInfoTbl +entryLblToInfoLbl (IdLabel n StaticConEntry) = IdLabel n StaticInfoTbl +entryLblToInfoLbl (CaseLabel n CaseReturnPt) = CaseLabel n CaseReturnInfo +entryLblToInfoLbl (RtsLabel (RtsEntry s)) = RtsLabel (RtsInfo s) +entryLblToInfoLbl (RtsLabel (RtsRet s)) = RtsLabel (RtsRetInfo s) +entryLblToInfoLbl (RtsLabel (RtsEntryFS s)) = RtsLabel (RtsInfoFS s) +entryLblToInfoLbl (RtsLabel (RtsRetFS s)) = RtsLabel (RtsRetInfoFS s) +entryLblToInfoLbl l = pprPanic "CLabel.entryLblToInfoLbl" (pprCLabel l) + +-- ----------------------------------------------------------------------------- +-- Does a CLabel need declaring before use or not? + +needsCDecl :: CLabel -> Bool + -- False <=> it's pre-declared; don't bother + -- don't bother declaring SRT & Bitmap labels, we always make sure + -- they are defined before use. +needsCDecl (IdLabel _ SRT) = False +needsCDecl (IdLabel _ SRTDesc) = False +needsCDecl (IdLabel _ Bitmap) = False +needsCDecl (IdLabel _ _) = True +needsCDecl (CaseLabel _ CaseReturnPt) = True +needsCDecl (CaseLabel _ CaseReturnInfo) = True +needsCDecl (ModuleInitLabel _ _) = True +needsCDecl (PlainModuleInitLabel _) = True +needsCDecl ModuleRegdLabel = False + +needsCDecl (CaseLabel _ _) = False +needsCDecl (AsmTempLabel _) = False +needsCDecl (RtsLabel _) = False +needsCDecl (ForeignLabel _ _ _) = False +needsCDecl (CC_Label _) = True +needsCDecl (CCS_Label _) = True + +-- Whether the label is an assembler temporary: + +isAsmTemp :: CLabel -> Bool -- is a local temporary for native code generation +isAsmTemp (AsmTempLabel _) = True +isAsmTemp _ = False + +-- ----------------------------------------------------------------------------- +-- Is a CLabel visible outside this object file or not? + +-- From the point of view of the code generator, a name is +-- externally visible if it has to be declared as exported +-- in the .o file's symbol table; that is, made non-static. + +externallyVisibleCLabel :: CLabel -> Bool -- not C "static" +externallyVisibleCLabel (CaseLabel _ _) = False +externallyVisibleCLabel (AsmTempLabel _) = False +externallyVisibleCLabel (ModuleInitLabel _ _)= True +externallyVisibleCLabel (PlainModuleInitLabel _)= True +externallyVisibleCLabel ModuleRegdLabel = False +externallyVisibleCLabel (RtsLabel _) = True +externallyVisibleCLabel (ForeignLabel _ _ _) = True +externallyVisibleCLabel (IdLabel id _) = isExternalName id +externallyVisibleCLabel (CC_Label _) = True +externallyVisibleCLabel (CCS_Label _) = True + + +-- ----------------------------------------------------------------------------- +-- Finding the "type" of a CLabel + +-- For generating correct types in label declarations: + +data CLabelType + = CodeLabel + | DataLabel + +labelType :: CLabel -> CLabelType +labelType (RtsLabel (RtsSelectorInfoTbl _ _)) = DataLabel +labelType (RtsLabel (RtsApInfoTbl _ _)) = DataLabel +labelType (RtsLabel (RtsData _)) = DataLabel +labelType (RtsLabel (RtsCode _)) = CodeLabel +labelType (RtsLabel (RtsInfo _)) = DataLabel +labelType (RtsLabel (RtsEntry _)) = CodeLabel +labelType (RtsLabel (RtsRetInfo _)) = DataLabel +labelType (RtsLabel (RtsRet _)) = CodeLabel +labelType (RtsLabel (RtsDataFS _)) = DataLabel +labelType (RtsLabel (RtsCodeFS _)) = CodeLabel +labelType (RtsLabel (RtsInfoFS _)) = DataLabel +labelType (RtsLabel (RtsEntryFS _)) = CodeLabel +labelType (RtsLabel (RtsRetInfoFS _)) = DataLabel +labelType (RtsLabel (RtsRetFS _)) = CodeLabel +labelType (CaseLabel _ CaseReturnInfo) = DataLabel +labelType (CaseLabel _ CaseReturnPt) = CodeLabel +labelType (ModuleInitLabel _ _) = CodeLabel +labelType (PlainModuleInitLabel _) = CodeLabel + +labelType (IdLabel _ info) = + case info of + InfoTbl -> DataLabel + Closure -> DataLabel + Bitmap -> DataLabel + ConInfoTbl -> DataLabel + StaticInfoTbl -> DataLabel + ClosureTable -> DataLabel + _ -> CodeLabel + +labelType _ = DataLabel + + +-- ----------------------------------------------------------------------------- +-- Does a CLabel need dynamic linkage? + +-- When referring to data in code, we need to know whether +-- that data resides in a DLL or not. [Win32 only.] +-- @labelDynamic@ returns @True@ if the label is located +-- in a DLL, be it a data reference or not. + +labelDynamic :: CLabel -> Bool +labelDynamic lbl = + case lbl of + -- The special case for RtsShouldNeverHappenCode is because the associated address is + -- NULL, i.e. not a DLL entry point + RtsLabel RtsShouldNeverHappenCode -> False + RtsLabel _ -> not opt_Static -- i.e., is the RTS in a DLL or not? + IdLabel n k -> isDllName n + ForeignLabel _ _ d -> d + ModuleInitLabel m _ -> (not opt_Static) && (not (isHomeModule m)) + PlainModuleInitLabel m -> (not opt_Static) && (not (isHomeModule m)) + _ -> False + +-- Basically the same as above, but this time for Darwin only. +-- The things that GHC does when labelDynamic returns true are not quite right +-- for Darwin. Also, every ForeignLabel might possibly be from a dynamic library, +-- and a 'false positive' doesn't really hurt on Darwin, so this just returns +-- True for every ForeignLabel. +-- +-- ToDo: Clean up DLL-related code so we can do away with the distinction +-- between this and labelDynamic above. + +labelCouldBeDynamic (ForeignLabel _ _ _) = True +labelCouldBeDynamic lbl = labelDynamic lbl + +{- +OLD?: These GRAN functions are needed for spitting out GRAN_FETCH() at the +right places. It is used to detect when the abstractC statement of an +CCodeBlock actually contains the code for a slow entry point. -- HWL + +We need at least @Eq@ for @CLabels@, because we want to avoid +duplicate declarations in generating C (see @labelSeenTE@ in +@PprAbsC@). +-} + +----------------------------------------------------------------------------- +-- Printing out CLabels. + +{- +Convention: + + _ + +where is _ for external names and for +internal names. is one of the following: + + info Info table + srt Static reference table + srtd Static reference table descriptor + entry Entry code (function, closure) + slow Slow entry code (if any) + ret Direct return address + vtbl Vector table + _alt Case alternative (tag n) + dflt Default case alternative + btm Large bitmap vector + closure Static closure + con_entry Dynamic Constructor entry code + con_info Dynamic Constructor info table + static_entry Static Constructor entry code + static_info Static Constructor info table + sel_info Selector info table + sel_entry Selector entry code + cc Cost centre + ccs Cost centre stack + +Many of these distinctions are only for documentation reasons. For +example, _ret is only distinguished from _entry to make it easy to +tell whether a code fragment is a return point or a closure/function +entry. +-} + +pprCLabel :: CLabel -> SDoc + +#if ! OMIT_NATIVE_CODEGEN +pprCLabel (AsmTempLabel u) + = getPprStyle $ \ sty -> + if asmStyle sty then + ptext asmTempLabelPrefix <> pprUnique u + else + char '_' <> pprUnique u +#endif + +pprCLabel lbl = +#if ! OMIT_NATIVE_CODEGEN + getPprStyle $ \ sty -> + if asmStyle sty then + maybe_underscore (pprAsmCLbl lbl) + else +#endif + pprCLbl lbl + +maybe_underscore doc + | underscorePrefix = pp_cSEP <> doc + | otherwise = doc + +-- In asm mode, we need to put the suffix on a stdcall ForeignLabel. +-- (The C compiler does this itself). +pprAsmCLbl (ForeignLabel fs (Just sz) _) + = ftext fs <> char '@' <> int sz +pprAsmCLbl lbl + = pprCLbl lbl + +pprCLbl (CaseLabel u CaseReturnPt) + = hcat [pprUnique u, ptext SLIT("_ret")] +pprCLbl (CaseLabel u CaseReturnInfo) + = hcat [pprUnique u, ptext SLIT("_info")] +pprCLbl (CaseLabel u (CaseAlt tag)) + = hcat [pprUnique u, pp_cSEP, int tag, ptext SLIT("_alt")] +pprCLbl (CaseLabel u CaseDefault) + = hcat [pprUnique u, ptext SLIT("_dflt")] + +pprCLbl (RtsLabel RtsShouldNeverHappenCode) = ptext SLIT("0") +-- used to be stg_error_entry but Windows can't have DLL entry points as static +-- initialisers, and besides, this ShouldNeverHappen, right? + +pprCLbl (RtsLabel (RtsCode str)) = ptext str +pprCLbl (RtsLabel (RtsData str)) = ptext str +pprCLbl (RtsLabel (RtsCodeFS str)) = ftext str +pprCLbl (RtsLabel (RtsDataFS str)) = ftext str + +pprCLbl (RtsLabel (RtsSelectorInfoTbl upd_reqd offset)) + = hcat [ptext SLIT("stg_sel_"), text (show offset), + ptext (if upd_reqd + then SLIT("_upd_info") + else SLIT("_noupd_info")) + ] + +pprCLbl (RtsLabel (RtsSelectorEntry upd_reqd offset)) + = hcat [ptext SLIT("stg_sel_"), text (show offset), + ptext (if upd_reqd + then SLIT("_upd_entry") + else SLIT("_noupd_entry")) + ] + +pprCLbl (RtsLabel (RtsApInfoTbl upd_reqd arity)) + = hcat [ptext SLIT("stg_ap_"), text (show arity), + ptext (if upd_reqd + then SLIT("_upd_info") + else SLIT("_noupd_info")) + ] + +pprCLbl (RtsLabel (RtsApEntry upd_reqd arity)) + = hcat [ptext SLIT("stg_ap_"), text (show arity), + ptext (if upd_reqd + then SLIT("_upd_entry") + else SLIT("_noupd_entry")) + ] + +pprCLbl (RtsLabel (RtsInfo fs)) + = ptext fs <> ptext SLIT("_info") + +pprCLbl (RtsLabel (RtsEntry fs)) + = ptext fs <> ptext SLIT("_entry") + +pprCLbl (RtsLabel (RtsRetInfo fs)) + = ptext fs <> ptext SLIT("_info") + +pprCLbl (RtsLabel (RtsRet fs)) + = ptext fs <> ptext SLIT("_ret") + +pprCLbl (RtsLabel (RtsInfoFS fs)) + = ftext fs <> ptext SLIT("_info") + +pprCLbl (RtsLabel (RtsEntryFS fs)) + = ftext fs <> ptext SLIT("_entry") + +pprCLbl (RtsLabel (RtsRetInfoFS fs)) + = ftext fs <> ptext SLIT("_info") + +pprCLbl (RtsLabel (RtsRetFS fs)) + = ftext fs <> ptext SLIT("_ret") + +pprCLbl (RtsLabel (RtsPrimOp primop)) + = ppr primop <> ptext SLIT("_fast") + +pprCLbl (RtsLabel (RtsSlowTickyCtr pat)) + = ptext SLIT("SLOW_CALL_") <> text pat <> ptext SLIT("_ctr") + +pprCLbl ModuleRegdLabel + = ptext SLIT("_module_registered") + +pprCLbl (ForeignLabel str _ _) + = ftext str + +pprCLbl (IdLabel id flavor) = ppr id <> ppIdFlavor flavor + +pprCLbl (CC_Label cc) = ppr cc +pprCLbl (CCS_Label ccs) = ppr ccs + +pprCLbl (ModuleInitLabel mod way) + = ptext SLIT("__stginit_") <> ftext (moduleNameFS (moduleName mod)) + <> char '_' <> text way +pprCLbl (PlainModuleInitLabel mod) + = ptext SLIT("__stginit_") <> ftext (moduleNameFS (moduleName mod)) + +ppIdFlavor :: IdLabelInfo -> SDoc +ppIdFlavor x = pp_cSEP <> + (case x of + Closure -> ptext SLIT("closure") + SRT -> ptext SLIT("srt") + SRTDesc -> ptext SLIT("srtd") + InfoTbl -> ptext SLIT("info") + Entry -> ptext SLIT("entry") + Slow -> ptext SLIT("slow") + RednCounts -> ptext SLIT("ct") + Bitmap -> ptext SLIT("btm") + ConEntry -> ptext SLIT("con_entry") + ConInfoTbl -> ptext SLIT("con_info") + StaticConEntry -> ptext SLIT("static_entry") + StaticInfoTbl -> ptext SLIT("static_info") + ClosureTable -> ptext SLIT("closure_tbl") + ) + + +pp_cSEP = char '_' + +-- ----------------------------------------------------------------------------- +-- Machine-dependent knowledge about labels. + +underscorePrefix :: Bool -- leading underscore on assembler labels? +underscorePrefix = (cLeadingUnderscore == "YES") + +asmTempLabelPrefix :: LitString -- for formatting labels +asmTempLabelPrefix = +#if alpha_TARGET_OS + {- The alpha assembler likes temporary labels to look like $L123 + instead of L123. (Don't toss the L, because then Lf28 + turns into $f28.) + -} + SLIT("$") +#elif darwin_TARGET_OS + SLIT("L") +#else + SLIT(".L") +#endif diff --git a/ghc/compiler/cmm/Cmm.hs b/ghc/compiler/cmm/Cmm.hs new file mode 100644 index 0000000000..cf76f459a7 --- /dev/null +++ b/ghc/compiler/cmm/Cmm.hs @@ -0,0 +1,305 @@ +----------------------------------------------------------------------------- +-- +-- Cmm data types +-- +-- (c) The University of Glasgow 2004 +-- +----------------------------------------------------------------------------- + +module Cmm ( + GenCmm(..), Cmm, + GenCmmTop(..), CmmTop, + GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts, + CmmStmt(..), + CmmCallTarget(..), + CmmStatic(..), Section(..), + CmmExpr(..), cmmExprRep, + CmmReg(..), cmmRegRep, + CmmLit(..), cmmLitRep, + LocalReg(..), localRegRep, + BlockId(..), + GlobalReg(..), globalRegRep, + + node, nodeReg, spReg, hpReg, + ) where + +#include "HsVersions.h" + +import MachOp +import CLabel ( CLabel ) +import ForeignCall ( CCallConv ) +import Unique ( Unique, Uniquable(..) ) +import FastString ( FastString ) + +----------------------------------------------------------------------------- +-- Cmm, CmmTop, CmmBasicBlock +----------------------------------------------------------------------------- + +-- A file is a list of top-level chunks. These may be arbitrarily +-- re-orderd during code generation. + +-- GenCmm is abstracted over +-- (a) the type of static data elements +-- (b) the contents of a basic block. +-- We expect there to be two main instances of this type: +-- (a) Plain C--, i.e. populated with CmmLit and CmmExpr respectively, +-- (b) Native code, populated with instructions +-- +newtype GenCmm d i = Cmm [GenCmmTop d i] + +type Cmm = GenCmm CmmStatic CmmStmt + +-- A top-level chunk, abstracted over the type of the contents of +-- the basic blocks (Cmm or instructions are the likely instantiations). +data GenCmmTop d i + = CmmProc + [d] -- Info table, may be empty + CLabel -- Used to generate both info & entry labels + [LocalReg] -- Argument locals live on entry (C-- procedure params) + [GenBasicBlock i] -- Code, may be empty. The first block is + -- the entry point. The order is otherwise initially + -- unimportant, but at some point the code gen will + -- fix the order. + + -- the BlockId of the first block does not give rise + -- to a label. To jump to the first block in a Proc, + -- use the appropriate CLabel. + + -- some static data. + | CmmData Section [d] -- constant values only + +type CmmTop = GenCmmTop CmmStatic CmmStmt + +-- A basic block containing a single label, at the beginning. +-- The list of basic blocks in a top-level code block may be re-ordered. +-- Fall-through is not allowed: there must be an explicit jump at the +-- end of each basic block, but the code generator might rearrange basic +-- blocks in order to turn some jumps into fallthroughs. + +data GenBasicBlock i = BasicBlock BlockId [i] + -- ToDo: Julian suggests that we might need to annotate this type + -- with the out & in edges in the graph, i.e. two * [BlockId]. This + -- information can be derived from the contents, but it might be + -- helpful to cache it here. + +type CmmBasicBlock = GenBasicBlock CmmStmt + +blockId :: GenBasicBlock i -> BlockId +-- The branch block id is that of the first block in +-- the branch, which is that branch's entry point +blockId (BasicBlock blk_id _ ) = blk_id + +blockStmts :: GenBasicBlock i -> [i] +blockStmts (BasicBlock _ stmts) = stmts + + +----------------------------------------------------------------------------- +-- CmmStmt +-- A "statement". Note that all branches are explicit: there are no +-- control transfers to computed addresses, except when transfering +-- control to a new function. +----------------------------------------------------------------------------- + +data CmmStmt + = CmmNop + | CmmComment FastString + + | CmmAssign CmmReg CmmExpr -- Assign to register + + | CmmStore CmmExpr CmmExpr -- Assign to memory location. Size is + -- given by cmmExprRep of the rhs. + + | CmmCall -- A foreign call, with + CmmCallTarget + [(CmmReg,MachHint)] -- zero or more results + [(CmmExpr,MachHint)] -- zero or more arguments + (Maybe [GlobalReg]) -- Global regs that may need to be saved + -- if they will be clobbered by the call. + -- Nothing <=> save *all* globals that + -- might be clobbered. + + | CmmBranch BlockId -- branch to another BB in this fn + + | CmmCondBranch CmmExpr BlockId -- conditional branch + + | CmmSwitch CmmExpr [Maybe BlockId] -- Table branch + -- The scrutinee is zero-based; + -- zero -> first block + -- one -> second block etc + -- Undefined outside range, and when there's a Nothing + + | CmmJump CmmExpr [LocalReg] -- Jump to another function, with these + -- parameters. + +----------------------------------------------------------------------------- +-- CmmCallTarget +-- +-- The target of a CmmCall. +----------------------------------------------------------------------------- + +data CmmCallTarget + = CmmForeignCall -- Call to a foreign function + CmmExpr -- literal label <=> static call + -- other expression <=> dynamic call + CCallConv -- The calling convention + + | CmmPrim -- Call to a "primitive" (eg. sin, cos) + CallishMachOp -- These might be implemented as inline + -- code by the backend. + +----------------------------------------------------------------------------- +-- CmmExpr +-- An expression. Expressions have no side effects. +----------------------------------------------------------------------------- + +data CmmExpr + = CmmLit CmmLit -- Literal + | CmmLoad CmmExpr MachRep -- Read memory location + | CmmReg CmmReg -- Contents of register + | CmmMachOp MachOp [CmmExpr] -- Machine operation (+, -, *, etc.) + | CmmRegOff CmmReg Int + -- CmmRegOff reg i + -- ** is shorthand only, meaning ** + -- CmmMachOp (MO_S_Add rep (CmmReg reg) (CmmLit (CmmInt i rep))) + -- where rep = cmmRegRep reg + +cmmExprRep :: CmmExpr -> MachRep +cmmExprRep (CmmLit lit) = cmmLitRep lit +cmmExprRep (CmmLoad _ rep) = rep +cmmExprRep (CmmReg reg) = cmmRegRep reg +cmmExprRep (CmmMachOp op _) = resultRepOfMachOp op +cmmExprRep (CmmRegOff reg _) = cmmRegRep reg + +data CmmReg + = CmmLocal LocalReg + | CmmGlobal GlobalReg + deriving( Eq ) + +cmmRegRep :: CmmReg -> MachRep +cmmRegRep (CmmLocal reg) = localRegRep reg +cmmRegRep (CmmGlobal reg) = globalRegRep reg + +data LocalReg + = LocalReg !Unique MachRep + +instance Eq LocalReg where + (LocalReg u1 _) == (LocalReg u2 _) = u1 == u2 + +instance Uniquable LocalReg where + getUnique (LocalReg uniq _) = uniq + +localRegRep :: LocalReg -> MachRep +localRegRep (LocalReg _ rep) = rep + +data CmmLit + = CmmInt Integer MachRep + -- Interpretation: the 2's complement representation of the value + -- is truncated to the specified size. This is easier than trying + -- to keep the value within range, because we don't know whether + -- it will be used as a signed or unsigned value (the MachRep doesn't + -- distinguish between signed & unsigned). + | CmmFloat Rational MachRep + | CmmLabel CLabel -- Address of label + | CmmLabelOff CLabel Int -- Address of label + byte offset + +cmmLitRep :: CmmLit -> MachRep +cmmLitRep (CmmInt _ rep) = rep +cmmLitRep (CmmFloat _ rep) = rep +cmmLitRep (CmmLabel _) = wordRep +cmmLitRep (CmmLabelOff _ _) = wordRep + +----------------------------------------------------------------------------- +-- A local label. + +-- Local labels must be unique within a single compilation unit. + +newtype BlockId = BlockId Unique + deriving (Eq,Ord) + +instance Uniquable BlockId where + getUnique (BlockId u) = u + +----------------------------------------------------------------------------- +-- Static Data +----------------------------------------------------------------------------- + +data Section + = Text + | Data + | ReadOnlyData + | UninitialisedData + | OtherSection String + +data CmmStatic + = CmmStaticLit CmmLit + -- a literal value, size given by cmmLitRep of the literal. + | CmmUninitialised Int + -- uninitialised data, N bytes long + | CmmAlign Int + -- align to next N-byte boundary (N must be a power of 2). + | CmmDataLabel CLabel + -- label the current position in this section. + | CmmString String + -- string of 8-bit values only, not zero terminated. + -- ToDo: might be more honest to use [Word8] here? + +----------------------------------------------------------------------------- +-- Global STG registers +----------------------------------------------------------------------------- + +data GlobalReg + -- Argument and return registers + = VanillaReg -- pointers, unboxed ints and chars + {-# UNPACK #-} !Int -- its number + + | FloatReg -- single-precision floating-point registers + {-# UNPACK #-} !Int -- its number + + | DoubleReg -- double-precision floating-point registers + {-# UNPACK #-} !Int -- its number + + | LongReg -- long int registers (64-bit, really) + {-# UNPACK #-} !Int -- its number + + -- STG registers + | Sp -- Stack ptr; points to last occupied stack location. + | SpLim -- Stack limit + | Hp -- Heap ptr; points to last occupied heap location. + | HpLim -- Heap limit register + | CurrentTSO -- pointer to current thread's TSO + | CurrentNursery -- pointer to allocation area + | HpAlloc -- allocation count for heap check failure + + -- We keep the address of some commonly-called + -- functions in the register table, to keep code + -- size down: + | GCEnter1 -- stg_gc_enter_1 + | GCFun -- stg_gc_fun + + -- Base offset for the register table, used for accessing registers + -- which do not have real registers assigned to them. This register + -- will only appear after we have expanded GlobalReg into memory accesses + -- (where necessary) in the native code generator. + | BaseReg + + deriving( Eq +#ifdef DEBUG + , Show +#endif + ) + +-- convenient aliases +spReg, hpReg, nodeReg :: CmmReg +spReg = CmmGlobal Sp +hpReg = CmmGlobal Hp +nodeReg = CmmGlobal node + +node :: GlobalReg +node = VanillaReg 1 + +globalRegRep :: GlobalReg -> MachRep +globalRegRep (VanillaReg _) = wordRep +globalRegRep (FloatReg _) = F32 +globalRegRep (DoubleReg _) = F64 +globalRegRep (LongReg _) = I64 +globalRegRep _ = wordRep diff --git a/ghc/compiler/cmm/CmmLex.x b/ghc/compiler/cmm/CmmLex.x new file mode 100644 index 0000000000..e1be71ab5f --- /dev/null +++ b/ghc/compiler/cmm/CmmLex.x @@ -0,0 +1,309 @@ +----------------------------------------------------------------------------- +-- (c) The University of Glasgow, 2004 +-- +-- Lexer for concrete Cmm. We try to stay close to the C-- spec, but there +-- are a few minor differences: +-- +-- * extra keywords for our macros, and float32/float64 types +-- * global registers (Sp,Hp, etc.) +-- +----------------------------------------------------------------------------- + +{ +module CmmLex ( + CmmToken(..), cmmlex, + ) where + +#include "HsVersions.h" + +import Cmm +import Lexer + +import SrcLoc +import UniqFM +import StringBuffer +import FastString +import Ctype +import Util ( readRational ) +--import TRACE +} + +$whitechar = [\ \t\n\r\f\v\xa0] +$white_no_nl = $whitechar # \n + +$ascdigit = 0-9 +$unidigit = \x01 +$digit = [$ascdigit $unidigit] +$octit = 0-7 +$hexit = [$digit A-F a-f] + +$unilarge = \x03 +$asclarge = [A-Z \xc0-\xd6 \xd8-\xde] +$large = [$asclarge $unilarge] + +$unismall = \x04 +$ascsmall = [a-z \xdf-\xf6 \xf8-\xff] +$small = [$ascsmall $unismall \_] + +$namebegin = [$large $small \_ \. \$ \@] +$namechar = [$namebegin $digit] + +@decimal = $digit+ +@octal = $octit+ +@hexadecimal = $hexit+ +@exponent = [eE] [\-\+]? @decimal + +@floating_point = @decimal \. @decimal @exponent? | @decimal @exponent + +@escape = \\ ([abfnrt\\\'\"\?] | x @hexadecimal | @octal) +@strchar = ($printable # [\"\\]) | @escape + +cmm :- + +$white_no_nl+ ; + +^\# (line)? { begin line_prag } + +-- single-line line pragmas, of the form +-- # "" \n + $digit+ { setLine line_prag1 } + \" ($printable # \")* \" { setFile line_prag2 } + .* { pop } + +<0> { + \n ; + + [\:\;\{\}\[\]\(\)\=\`\~\/\*\%\-\+\&\^\|\>\<\,\!] { special_char } + + ".." { kw CmmT_DotDot } + "::" { kw CmmT_DoubleColon } + ">>" { kw CmmT_Shr } + "<<" { kw CmmT_Shl } + ">=" { kw CmmT_Ge } + "<=" { kw CmmT_Le } + "==" { kw CmmT_Eq } + "!=" { kw CmmT_Ne } + "&&" { kw CmmT_BoolAnd } + "||" { kw CmmT_BoolOr } + + R@decimal { global_regN VanillaReg } + F@decimal { global_regN FloatReg } + D@decimal { global_regN DoubleReg } + L@decimal { global_regN LongReg } + Sp { global_reg Sp } + SpLim { global_reg SpLim } + Hp { global_reg Hp } + HpLim { global_reg HpLim } + CurrentTSO { global_reg CurrentTSO } + CurrentNursery { global_reg CurrentNursery } + HpAlloc { global_reg HpAlloc } + + $namebegin $namechar* { name } + + 0 @octal { tok_octal } + @decimal { tok_decimal } + 0[xX] @hexadecimal { tok_hexadecimal } + @floating_point { strtoken tok_float } + + \" @strchar* \" { strtoken tok_string } +} + +{ +data CmmToken + = CmmT_SpecChar Char + | CmmT_DotDot + | CmmT_DoubleColon + | CmmT_Shr + | CmmT_Shl + | CmmT_Ge + | CmmT_Le + | CmmT_Eq + | CmmT_Ne + | CmmT_BoolAnd + | CmmT_BoolOr + | CmmT_CLOSURE + | CmmT_INFO_TABLE + | CmmT_INFO_TABLE_RET + | CmmT_INFO_TABLE_FUN + | CmmT_INFO_TABLE_CONSTR + | CmmT_INFO_TABLE_SELECTOR + | CmmT_else + | CmmT_export + | CmmT_section + | CmmT_align + | CmmT_goto + | CmmT_if + | CmmT_jump + | CmmT_foreign + | CmmT_import + | CmmT_switch + | CmmT_case + | CmmT_default + | CmmT_bits8 + | CmmT_bits16 + | CmmT_bits32 + | CmmT_bits64 + | CmmT_float32 + | CmmT_float64 + | CmmT_GlobalReg GlobalReg + | CmmT_Name FastString + | CmmT_String String + | CmmT_Int Integer + | CmmT_Float Rational + | CmmT_EOF +#ifdef DEBUG + deriving (Show) +#endif + +-- ----------------------------------------------------------------------------- +-- Lexer actions + +type Action = SrcSpan -> StringBuffer -> Int -> P (Located CmmToken) + +begin :: Int -> Action +begin code _span _str _len = do pushLexState code; lexToken + +pop :: Action +pop _span _buf _len = do popLexState; lexToken + +special_char :: Action +special_char span buf len = return (L span (CmmT_SpecChar (currentChar buf))) + +kw :: CmmToken -> Action +kw tok span buf len = return (L span tok) + +global_regN :: (Int -> GlobalReg) -> Action +global_regN con span buf len + = return (L span (CmmT_GlobalReg (con (fromIntegral n)))) + where buf' = stepOn buf + n = parseInteger buf' (len-1) 10 octDecDigit + +global_reg :: GlobalReg -> Action +global_reg r span buf len = return (L span (CmmT_GlobalReg r)) + +strtoken :: (String -> CmmToken) -> Action +strtoken f span buf len = + return (L span $! (f $! lexemeToString buf len)) + +name :: Action +name span buf len = + case lookupUFM reservedWordsFM fs of + Just tok -> return (L span tok) + Nothing -> return (L span (CmmT_Name fs)) + where + fs = lexemeToFastString buf len + +reservedWordsFM = listToUFM $ + map (\(x, y) -> (mkFastString x, y)) [ + ( "CLOSURE", CmmT_CLOSURE ), + ( "INFO_TABLE", CmmT_INFO_TABLE ), + ( "INFO_TABLE_RET", CmmT_INFO_TABLE_RET ), + ( "INFO_TABLE_FUN", CmmT_INFO_TABLE_FUN ), + ( "INFO_TABLE_CONSTR", CmmT_INFO_TABLE_CONSTR ), + ( "INFO_TABLE_SELECTOR",CmmT_INFO_TABLE_SELECTOR ), + ( "else", CmmT_else ), + ( "export", CmmT_export ), + ( "section", CmmT_section ), + ( "align", CmmT_align ), + ( "goto", CmmT_goto ), + ( "if", CmmT_if ), + ( "jump", CmmT_jump ), + ( "foreign", CmmT_foreign ), + ( "import", CmmT_import ), + ( "switch", CmmT_switch ), + ( "case", CmmT_case ), + ( "default", CmmT_default ), + ( "bits8", CmmT_bits8 ), + ( "bits16", CmmT_bits16 ), + ( "bits32", CmmT_bits32 ), + ( "bits64", CmmT_bits64 ), + ( "float32", CmmT_float32 ), + ( "float64", CmmT_float64 ) + ] + +tok_decimal span buf len + = return (L span (CmmT_Int $! parseInteger buf len 10 octDecDigit)) + +tok_octal span buf len + = return (L span (CmmT_Int $! parseInteger (stepOn buf) (len-1) 8 octDecDigit)) + +tok_hexadecimal span buf len + = return (L span (CmmT_Int $! parseInteger (stepOnBy 2 buf) (len-2) 16 hexDigit)) + +tok_float str = CmmT_Float $! readRational str + +tok_string str = CmmT_String (read str) + -- urk, not quite right, but it'll do for now + +-- ----------------------------------------------------------------------------- +-- Line pragmas + +setLine :: Int -> Action +setLine code span buf len = do + let line = parseInteger buf len 10 octDecDigit + setSrcLoc (mkSrcLoc (srcSpanFile span) (fromIntegral line - 1) 0) + -- subtract one: the line number refers to the *following* line + -- trace ("setLine " ++ show line) $ do + popLexState + pushLexState code + lexToken + +setFile :: Int -> Action +setFile code span buf len = do + let file = lexemeToFastString (stepOn buf) (len-2) + setSrcLoc (mkSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span)) + popLexState + pushLexState code + lexToken + +-- ----------------------------------------------------------------------------- +-- This is the top-level function: called from the parser each time a +-- new token is to be read from the input. + +cmmlex :: (Located CmmToken -> P a) -> P a +cmmlex cont = do + tok@(L _ tok__) <- lexToken + --trace ("token: " ++ show tok__) $ do + cont tok + +lexToken :: P (Located CmmToken) +lexToken = do + inp@(loc1,buf) <- getInput + sc <- getLexState + case alexScan inp sc of + AlexEOF -> do let span = mkSrcSpan loc1 loc1 + setLastToken span 0 + return (L span CmmT_EOF) + AlexError (loc2,_) -> do failLocMsgP loc1 loc2 "lexical error" + AlexSkip inp2 _ -> do + setInput inp2 + lexToken + AlexToken inp2@(end,buf2) len t -> do + setInput inp2 + let span = mkSrcSpan loc1 end + span `seq` setLastToken span len + t span buf len + +-- ----------------------------------------------------------------------------- +-- Monad stuff + +-- Stuff that Alex needs to know about our input type: +type AlexInput = (SrcLoc,StringBuffer) + +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar (_,s) = prevChar s '\n' + +alexGetChar :: AlexInput -> Maybe (Char,AlexInput) +alexGetChar (loc,s) + | atEnd s = Nothing + | otherwise = c `seq` loc' `seq` s' `seq` Just (c, (loc', s')) + where c = currentChar s + loc' = advanceSrcLoc loc c + s' = stepOn s + +getInput :: P AlexInput +getInput = P $ \s@PState{ loc=l, buffer=b } -> POk s (l,b) + +setInput :: AlexInput -> P () +setInput (l,b) = P $ \s -> POk s{ loc=l, buffer=b } () +} diff --git a/ghc/compiler/cmm/CmmLint.hs b/ghc/compiler/cmm/CmmLint.hs new file mode 100644 index 0000000000..d82fe7c3ac --- /dev/null +++ b/ghc/compiler/cmm/CmmLint.hs @@ -0,0 +1,152 @@ +----------------------------------------------------------------------------- +-- +-- CmmLint: checking the correctness of Cmm statements and expressions +-- +-- (c) The University of Glasgow 2004 +-- +----------------------------------------------------------------------------- + +module CmmLint ( + cmmLint, cmmLintTop + ) where + +#include "HsVersions.h" + +import Cmm +import CLabel ( pprCLabel ) +import MachOp +import Outputable +import PprCmm +import Unique ( getUnique ) +import Constants ( wORD_SIZE ) + +import Monad ( when ) + +-- ----------------------------------------------------------------------------- +-- Exported entry points: + +cmmLint :: Cmm -> Maybe SDoc +cmmLint (Cmm tops) = runCmmLint $ mapM_ lintCmmTop tops + +cmmLintTop :: CmmTop -> Maybe SDoc +cmmLintTop top = runCmmLint $ lintCmmTop top + +runCmmLint :: CmmLint a -> Maybe SDoc +runCmmLint l = + case unCL l of + Left err -> Just (ptext SLIT("Cmm lint error:") $$ nest 2 err) + Right _ -> Nothing + +lintCmmTop (CmmProc _info lbl _args blocks) + = addLintInfo (text "in proc " <> pprCLabel lbl) $ + mapM_ lintCmmBlock blocks +lintCmmTop _other + = return () + +lintCmmBlock (BasicBlock id stmts) + = addLintInfo (text "in basic block " <> ppr (getUnique id)) $ + mapM_ lintCmmStmt stmts + +-- ----------------------------------------------------------------------------- +-- lintCmmExpr + +-- Checks whether a CmmExpr is "type-correct", and check for obvious-looking +-- byte/word mismatches. + +lintCmmExpr :: CmmExpr -> CmmLint MachRep +lintCmmExpr (CmmLoad expr rep) = do + lintCmmExpr expr + when (machRepByteWidth rep >= wORD_SIZE) $ + cmmCheckWordAddress expr + return rep +lintCmmExpr expr@(CmmMachOp op args) = do + mapM_ lintCmmExpr args + if map cmmExprRep args == machOpArgReps op + then cmmCheckMachOp op args + else cmmLintMachOpErr expr +lintCmmExpr (CmmRegOff reg offset) + = lintCmmExpr (CmmMachOp (MO_Add rep) + [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)]) + where rep = cmmRegRep reg +lintCmmExpr expr = + return (cmmExprRep expr) + +-- Check for some common byte/word mismatches (eg. Sp + 1) +cmmCheckMachOp op args@[CmmReg reg, CmmLit (CmmInt i _)] + | isWordOffsetReg reg && isOffsetOp op && i `rem` fromIntegral wORD_SIZE /= 0 + = cmmLintDubiousWordOffset (CmmMachOp op args) +cmmCheckMachOp op [lit@(CmmLit (CmmInt i _)), reg@(CmmReg _)] + = cmmCheckMachOp op [reg, lit] +cmmCheckMachOp op args + = return (resultRepOfMachOp op) + +isWordOffsetReg (CmmGlobal Sp) = True +isWordOffsetReg (CmmGlobal Hp) = True +isWordOffsetReg _ = False + +isOffsetOp (MO_Add _) = True +isOffsetOp (MO_Sub _) = True +isOffsetOp _ = False + +-- This expression should be an address from which a word can be loaded: +-- check for funny-looking sub-word offsets. +cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)]) + | isOffsetOp op && i `rem` fromIntegral wORD_SIZE /= 0 + = cmmLintDubiousWordOffset e +cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg]) + | isOffsetOp op && i `rem` fromIntegral wORD_SIZE /= 0 + = cmmLintDubiousWordOffset e +cmmCheckWordAddress _ + = return () + + +lintCmmStmt :: CmmStmt -> CmmLint () +lintCmmStmt stmt@(CmmAssign reg expr) = do + erep <- lintCmmExpr expr + if (erep == cmmRegRep reg) + then return () + else cmmLintAssignErr stmt +lintCmmStmt (CmmStore l r) = do + lintCmmExpr l + lintCmmExpr r + return () +lintCmmStmt (CmmCall _target _res args _vols) = mapM_ (lintCmmExpr.fst) args +lintCmmStmt (CmmCondBranch e _id) = lintCmmExpr e >> return () +lintCmmStmt (CmmSwitch e _branches) = lintCmmExpr e >> return () +lintCmmStmt (CmmJump e _args) = lintCmmExpr e >> return () +lintCmmStmt _other = return () + +-- ----------------------------------------------------------------------------- +-- CmmLint monad + +-- just a basic error monad: + +newtype CmmLint a = CmmLint { unCL :: Either SDoc a } + +instance Monad CmmLint where + CmmLint m >>= k = CmmLint $ case m of + Left e -> Left e + Right a -> unCL (k a) + return a = CmmLint (Right a) + +cmmLintErr :: SDoc -> CmmLint a +cmmLintErr msg = CmmLint (Left msg) + +addLintInfo :: SDoc -> CmmLint a -> CmmLint a +addLintInfo info thing = CmmLint $ + case unCL thing of + Left err -> Left (hang info 2 err) + Right a -> Right a + +cmmLintMachOpErr :: CmmExpr -> CmmLint a +cmmLintMachOpErr expr = cmmLintErr (text "in MachOp application: " $$ + nest 2 (pprExpr expr)) + +cmmLintAssignErr :: CmmStmt -> CmmLint a +cmmLintAssignErr stmt = cmmLintErr (text "in assignment: " $$ + nest 2 (pprStmt stmt)) + +cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a +cmmLintDubiousWordOffset expr + = cmmLintErr (text "offset is not a multiple of words: " $$ + nest 2 (pprExpr expr)) diff --git a/ghc/compiler/cmm/CmmParse.y b/ghc/compiler/cmm/CmmParse.y new file mode 100644 index 0000000000..e409f25d58 --- /dev/null +++ b/ghc/compiler/cmm/CmmParse.y @@ -0,0 +1,878 @@ +----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow, 2004 +-- +-- Parser for concrete Cmm. +-- +----------------------------------------------------------------------------- + +{ +module CmmParse ( parseCmmFile ) where + +import CgMonad +import CgHeapery +import CgUtils +import CgProf +import CgTicky +import CgInfoTbls +import CgForeignCall +import CgTailCall ( pushUnboxedTuple ) +import CgStackery ( emitPushUpdateFrame ) +import ClosureInfo ( C_SRT(..) ) +import CgCallConv ( smallLiveness ) +import CgClosure ( emitBlackHoleCode ) +import CostCentre ( dontCareCCS ) + +import Cmm +import PprCmm +import CmmUtils ( mkIntCLit, mkLblExpr ) +import CmmLex +import CLabel +import MachOp +import SMRep ( tablesNextToCode, fixedHdrSize, CgRep(..) ) +import Lexer + +import ForeignCall ( CCallConv(..) ) +import Literal ( mkMachInt ) +import Unique +import UniqFM +import SrcLoc +import CmdLineOpts ( DynFlags, DynFlag(..), opt_SccProfilingOn ) +import ErrUtils ( printError, dumpIfSet_dyn, showPass ) +import StringBuffer ( hGetStringBuffer ) +import FastString +import Panic ( panic ) +import Constants ( wORD_SIZE ) +import Outputable + +import Monad ( when ) + +#include "HsVersions.h" +} + +%token + ':' { L _ (CmmT_SpecChar ':') } + ';' { L _ (CmmT_SpecChar ';') } + '{' { L _ (CmmT_SpecChar '{') } + '}' { L _ (CmmT_SpecChar '}') } + '[' { L _ (CmmT_SpecChar '[') } + ']' { L _ (CmmT_SpecChar ']') } + '(' { L _ (CmmT_SpecChar '(') } + ')' { L _ (CmmT_SpecChar ')') } + '=' { L _ (CmmT_SpecChar '=') } + '`' { L _ (CmmT_SpecChar '`') } + '~' { L _ (CmmT_SpecChar '~') } + '/' { L _ (CmmT_SpecChar '/') } + '*' { L _ (CmmT_SpecChar '*') } + '%' { L _ (CmmT_SpecChar '%') } + '-' { L _ (CmmT_SpecChar '-') } + '+' { L _ (CmmT_SpecChar '+') } + '&' { L _ (CmmT_SpecChar '&') } + '^' { L _ (CmmT_SpecChar '^') } + '|' { L _ (CmmT_SpecChar '|') } + '>' { L _ (CmmT_SpecChar '>') } + '<' { L _ (CmmT_SpecChar '<') } + ',' { L _ (CmmT_SpecChar ',') } + '!' { L _ (CmmT_SpecChar '!') } + + '..' { L _ (CmmT_DotDot) } + '::' { L _ (CmmT_DoubleColon) } + '>>' { L _ (CmmT_Shr) } + '<<' { L _ (CmmT_Shl) } + '>=' { L _ (CmmT_Ge) } + '<=' { L _ (CmmT_Le) } + '==' { L _ (CmmT_Eq) } + '!=' { L _ (CmmT_Ne) } + '&&' { L _ (CmmT_BoolAnd) } + '||' { L _ (CmmT_BoolOr) } + + 'CLOSURE' { L _ (CmmT_CLOSURE) } + 'INFO_TABLE' { L _ (CmmT_INFO_TABLE) } + 'INFO_TABLE_RET'{ L _ (CmmT_INFO_TABLE_RET) } + 'INFO_TABLE_FUN'{ L _ (CmmT_INFO_TABLE_FUN) } + 'INFO_TABLE_CONSTR'{ L _ (CmmT_INFO_TABLE_CONSTR) } + 'INFO_TABLE_SELECTOR'{ L _ (CmmT_INFO_TABLE_SELECTOR) } + 'else' { L _ (CmmT_else) } + 'export' { L _ (CmmT_export) } + 'section' { L _ (CmmT_section) } + 'align' { L _ (CmmT_align) } + 'goto' { L _ (CmmT_goto) } + 'if' { L _ (CmmT_if) } + 'jump' { L _ (CmmT_jump) } + 'foreign' { L _ (CmmT_foreign) } + 'import' { L _ (CmmT_import) } + 'switch' { L _ (CmmT_switch) } + 'case' { L _ (CmmT_case) } + 'default' { L _ (CmmT_default) } + 'bits8' { L _ (CmmT_bits8) } + 'bits16' { L _ (CmmT_bits16) } + 'bits32' { L _ (CmmT_bits32) } + 'bits64' { L _ (CmmT_bits64) } + 'float32' { L _ (CmmT_float32) } + 'float64' { L _ (CmmT_float64) } + + GLOBALREG { L _ (CmmT_GlobalReg $$) } + NAME { L _ (CmmT_Name $$) } + STRING { L _ (CmmT_String $$) } + INT { L _ (CmmT_Int $$) } + FLOAT { L _ (CmmT_Float $$) } + +%monad { P } { >>= } { return } +%lexer { cmmlex } { L _ CmmT_EOF } +%name cmmParse cmm +%tokentype { Located CmmToken } + +-- C-- operator precedences, taken from the C-- spec +%right '||' -- non-std extension, called %disjoin in C-- +%right '&&' -- non-std extension, called %conjoin in C-- +%right '!' +%nonassoc '>=' '>' '<=' '<' '!=' '==' +%left '|' +%left '^' +%left '&' +%left '>>' '<<' +%left '-' '+' +%left '/' '*' '%' +%right '~' + +%% + +cmm :: { ExtCode } + : {- empty -} { return () } + | cmmtop cmm { do $1; $2 } + +cmmtop :: { ExtCode } + : cmmproc { $1 } + | cmmdata { $1 } + | decl { $1 } + | 'CLOSURE' '(' NAME ',' NAME lits ')' ';' + { do lits <- sequence $6; + staticClosure $3 $5 (map getLit lits) } + +-- The only static closures in the RTS are dummy closures like +-- stg_END_TSO_QUEUE_closure and stg_dummy_ret. We don't need +-- to provide the full generality of static closures here. +-- In particular: +-- * CCS can always be CCS_DONT_CARE +-- * closure is always extern +-- * payload is always empty +-- * we can derive closure and info table labels from a single NAME + +cmmdata :: { ExtCode } + : 'section' STRING '{' statics '}' + { do ss <- sequence $4; + code (emitData (section $2) (concat ss)) } + +statics :: { [ExtFCode [CmmStatic]] } + : {- empty -} { [] } + | static statics { $1 : $2 } + +-- Strings aren't used much in the RTS HC code, so it doesn't seem +-- worth allowing inline strings. C-- doesn't allow them anyway. +static :: { ExtFCode [CmmStatic] } + : NAME ':' { return [CmmDataLabel (mkRtsDataLabelFS $1)] } + | type expr ';' { do e <- $2; + return [CmmStaticLit (getLit e)] } + | type ';' { return [CmmUninitialised + (machRepByteWidth $1)] } + | 'bits8' '[' ']' STRING ';' { return [CmmString $4] } + | 'bits8' '[' INT ']' ';' { return [CmmUninitialised + (fromIntegral $3)] } + | typenot8 '[' INT ']' ';' { return [CmmUninitialised + (machRepByteWidth $1 * + fromIntegral $3)] } + | 'align' INT ';' { return [CmmAlign (fromIntegral $2)] } + | 'CLOSURE' '(' NAME lits ')' + { do lits <- sequence $4; + return $ map CmmStaticLit $ + mkStaticClosure (mkRtsInfoLabelFS $3) + dontCareCCS (map getLit lits) [] [] } + -- arrays of closures required for the CHARLIKE & INTLIKE arrays + +lits :: { [ExtFCode CmmExpr] } + : {- empty -} { [] } + | ',' expr lits { $2 : $3 } + +cmmproc :: { ExtCode } + : info '{' body '}' + { do (info_lbl, info1, info2) <- $1; + stmts <- getCgStmtsEC (loopDecls $3) + blks <- code (cgStmtsToBlocks stmts) + code (emitInfoTableAndCode info_lbl info1 info2 [] blks) } + + | info ';' + { do (info_lbl, info1, info2) <- $1; + code (emitInfoTableAndCode info_lbl info1 info2 [] []) } + + | NAME '{' body '}' + { do stmts <- getCgStmtsEC (loopDecls $3); + blks <- code (cgStmtsToBlocks stmts) + code (emitProc [] (mkRtsCodeLabelFS $1) [] blks) } + +info :: { ExtFCode (CLabel, [CmmLit],[CmmLit]) } + : 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')' + -- ptrs, nptrs, closure type, description, type + { stdInfo $3 $5 $7 0 $9 $11 $13 } + + | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')' + -- ptrs, nptrs, closure type, description, type, fun type + { funInfo $3 $5 $7 $9 $11 $13 $15 } + + | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')' + -- ptrs, nptrs, tag, closure type, description, type + { stdInfo $3 $5 $7 $9 $11 $13 $15 } + + | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')' + -- selector, closure type, description, type + { basicInfo $3 (mkIntCLit (fromIntegral $5)) 0 $7 $9 $11 } + + | 'INFO_TABLE_RET' '(' NAME ',' INT ',' INT ',' INT maybe_vec ')' + { retInfo $3 $5 $7 $9 $10 } + +maybe_vec :: { [CLabel] } + : {- empty -} { [] } + | ',' NAME maybe_vec { mkRtsCodeLabelFS $2 : $3 } + +body :: { ExtCode } + : {- empty -} { return () } + | decl body { do $1; $2 } + | stmt body { do $1; $2 } + +decl :: { ExtCode } + : type names ';' { mapM_ (newLocal $1) $2 } + | 'import' names ';' { return () } -- ignore imports + | 'export' names ';' { return () } -- ignore exports + +names :: { [FastString] } + : NAME { [$1] } + | NAME ',' names { $1 : $3 } + +stmt :: { ExtCode } + : ';' { nopEC } + + | block_id ':' { code (labelC $1) } + + | lreg '=' expr ';' + { do reg <- $1; e <- $3; stmtEC (CmmAssign reg e) } + | type '[' expr ']' '=' expr ';' + { doStore $1 $3 $6 } + | 'foreign' STRING expr '(' hint_exprs0 ')' vols ';' + {% foreignCall $2 [] $3 $5 $7 } + | lreg '=' 'foreign' STRING expr '(' hint_exprs0 ')' vols ';' + {% let result = do r <- $1; return (r,NoHint) in + foreignCall $4 [result] $5 $7 $9 } + | STRING lreg '=' 'foreign' STRING expr '(' hint_exprs0 ')' vols ';' + {% do h <- parseHint $1; + let result = do r <- $2; return (r,h) in + foreignCall $5 [result] $6 $8 $10 } + -- stmt-level macros, stealing syntax from ordinary C-- function calls. + -- Perhaps we ought to use the %%-form? + | NAME '(' exprs0 ')' ';' + {% stmtMacro $1 $3 } + | 'switch' maybe_range expr '{' arms default '}' + { doSwitch $2 $3 $5 $6 } + | 'goto' block_id ';' + { stmtEC (CmmBranch $2) } + | 'jump' expr {-maybe_actuals-} ';' + { do e <- $2; stmtEC (CmmJump e []) } + | 'if' bool_expr '{' body '}' else + { ifThenElse $2 $4 $6 } + +bool_expr :: { ExtFCode BoolExpr } + : bool_op { $1 } + | expr { do e <- $1; return (BoolTest e) } + +bool_op :: { ExtFCode BoolExpr } + : bool_expr '&&' bool_expr { do e1 <- $1; e2 <- $3; + return (BoolAnd e1 e2) } + | bool_expr '||' bool_expr { do e1 <- $1; e2 <- $3; + return (BoolOr e1 e2) } + | '!' bool_expr { do e <- $2; return (BoolNot e) } + | '(' bool_op ')' { $2 } + +-- This is not C-- syntax. What to do? +vols :: { Maybe [GlobalReg] } + : {- empty -} { Nothing } + | '[' globals ']' { Just $2 } + +globals :: { [GlobalReg] } + : GLOBALREG { [$1] } + | GLOBALREG ',' globals { $1 : $3 } + +maybe_range :: { Maybe (Int,Int) } + : '[' INT '..' INT ']' { Just (fromIntegral $2, fromIntegral $4) } + | {- empty -} { Nothing } + +arms :: { [([Int],ExtCode)] } + : {- empty -} { [] } + | arm arms { $1 : $2 } + +arm :: { ([Int],ExtCode) } + : 'case' ints ':' '{' body '}' { ($2, $5) } + +ints :: { [Int] } + : INT { [ fromIntegral $1 ] } + | INT ',' ints { fromIntegral $1 : $3 } + +default :: { Maybe ExtCode } + : 'default' ':' '{' body '}' { Just $4 } + -- taking a few liberties with the C-- syntax here; C-- doesn't have + -- 'default' branches + | {- empty -} { Nothing } + +else :: { ExtCode } + : {- empty -} { nopEC } + | 'else' '{' body '}' { $3 } + +-- we have to write this out longhand so that Happy's precedence rules +-- can kick in. +expr :: { ExtFCode CmmExpr } + : expr '/' expr { mkMachOp MO_U_Quot [$1,$3] } + | expr '*' expr { mkMachOp MO_Mul [$1,$3] } + | expr '%' expr { mkMachOp MO_U_Rem [$1,$3] } + | expr '-' expr { mkMachOp MO_Sub [$1,$3] } + | expr '+' expr { mkMachOp MO_Add [$1,$3] } + | expr '>>' expr { mkMachOp MO_U_Shr [$1,$3] } + | expr '<<' expr { mkMachOp MO_Shl [$1,$3] } + | expr '&' expr { mkMachOp MO_And [$1,$3] } + | expr '^' expr { mkMachOp MO_Xor [$1,$3] } + | expr '|' expr { mkMachOp MO_Or [$1,$3] } + | expr '>=' expr { mkMachOp MO_U_Ge [$1,$3] } + | expr '>' expr { mkMachOp MO_U_Gt [$1,$3] } + | expr '<=' expr { mkMachOp MO_U_Le [$1,$3] } + | expr '<' expr { mkMachOp MO_U_Lt [$1,$3] } + | expr '!=' expr { mkMachOp MO_Ne [$1,$3] } + | expr '==' expr { mkMachOp MO_Eq [$1,$3] } + | '~' expr { mkMachOp MO_Not [$2] } + | '-' expr { mkMachOp MO_S_Neg [$2] } + | expr0 '`' NAME '`' expr0 {% do { mo <- nameToMachOp $3 ; + return (mkMachOp mo [$1,$5]) } } + | expr0 { $1 } + +expr0 :: { ExtFCode CmmExpr } + : INT maybe_ty { return (CmmLit (CmmInt $1 $2)) } + | FLOAT maybe_ty { return (CmmLit (CmmFloat $1 $2)) } + | STRING { do s <- code (mkStringCLit $1); + return (CmmLit s) } + | reg { $1 } + | type '[' expr ']' { do e <- $3; return (CmmLoad e $1) } + | '%' NAME '(' exprs0 ')' {% exprOp $2 $4 } + | '(' expr ')' { $2 } + + +-- leaving out the type of a literal gives you the native word size in C-- +maybe_ty :: { MachRep } + : {- empty -} { wordRep } + | '::' type { $2 } + +hint_exprs0 :: { [ExtFCode (CmmExpr, MachHint)] } + : {- empty -} { [] } + | hint_exprs { $1 } + +hint_exprs :: { [ExtFCode (CmmExpr, MachHint)] } + : hint_expr { [$1] } + | hint_expr ',' hint_exprs { $1 : $3 } + +hint_expr :: { ExtFCode (CmmExpr, MachHint) } + : expr { do e <- $1; return (e, inferHint e) } + | expr STRING {% do h <- parseHint $2; + return $ do + e <- $1; return (e,h) } + +exprs0 :: { [ExtFCode CmmExpr] } + : {- empty -} { [] } + | exprs { $1 } + +exprs :: { [ExtFCode CmmExpr] } + : expr { [ $1 ] } + | expr ',' exprs { $1 : $3 } + +reg :: { ExtFCode CmmExpr } + : NAME { lookupName $1 } + | GLOBALREG { return (CmmReg (CmmGlobal $1)) } + +lreg :: { ExtFCode CmmReg } + : NAME { do e <- lookupName $1; + return $ + case e of + CmmReg r -> r + other -> pprPanic "CmmParse:" (ftext $1 <> text " not a register") } + | GLOBALREG { return (CmmGlobal $1) } + +block_id :: { BlockId } + : NAME { BlockId (newTagUnique (getUnique $1) 'L') } + -- TODO: ugh. The unique of a FastString has a null + -- tag, so we have to put our own tag on. We should + -- really make a new unique for every label, and keep + -- them in an environment. + +type :: { MachRep } + : 'bits8' { I8 } + | typenot8 { $1 } + +typenot8 :: { MachRep } + : 'bits16' { I16 } + | 'bits32' { I32 } + | 'bits64' { I64 } + | 'float32' { F32 } + | 'float64' { F64 } +{ +section :: String -> Section +section "text" = Text +section "data" = Data +section "rodata" = ReadOnlyData +section "bss" = UninitialisedData +section s = OtherSection s + +-- mkMachOp infers the type of the MachOp from the type of its first +-- argument. We assume that this is correct: for MachOps that don't have +-- symmetrical args (e.g. shift ops), the first arg determines the type of +-- the op. +mkMachOp :: (MachRep -> MachOp) -> [ExtFCode CmmExpr] -> ExtFCode CmmExpr +mkMachOp fn args = do + arg_exprs <- sequence args + return (CmmMachOp (fn (cmmExprRep (head arg_exprs))) arg_exprs) + +getLit :: CmmExpr -> CmmLit +getLit (CmmLit l) = l +getLit (CmmMachOp (MO_S_Neg _) [CmmLit (CmmInt i r)]) = CmmInt (negate i) r +getLit _ = panic "invalid literal" -- TODO messy failure + +nameToMachOp :: FastString -> P (MachRep -> MachOp) +nameToMachOp name = + case lookupUFM machOps name of + Nothing -> fail ("unknown primitive " ++ unpackFS name) + Just m -> return m + +exprOp :: FastString -> [ExtFCode CmmExpr] -> P (ExtFCode CmmExpr) +exprOp name args_code = + case lookupUFM exprMacros name of + Just f -> return $ do + args <- sequence args_code + return (f args) + Nothing -> do + mo <- nameToMachOp name + return $ mkMachOp mo args_code + +exprMacros :: UniqFM ([CmmExpr] -> CmmExpr) +exprMacros = listToUFM [ + ( FSLIT("ENTRY_CODE"), \ [x] -> entryCode x ), + ( FSLIT("GET_ENTRY"), \ [x] -> entryCode (closureInfoPtr x) ), + ( FSLIT("STD_INFO"), \ [x] -> infoTable x ), + ( FSLIT("GET_STD_INFO"), \ [x] -> infoTable (closureInfoPtr x) ), + ( FSLIT("GET_FUN_INFO"), \ [x] -> funInfoTable (closureInfoPtr x) ), + ( FSLIT("INFO_TYPE"), \ [x] -> infoTableClosureType x ), + ( FSLIT("INFO_PTRS"), \ [x] -> infoTablePtrs x ), + ( FSLIT("INFO_NPTRS"), \ [x] -> infoTableNonPtrs x ), + ( FSLIT("RET_VEC"), \ [info, conZ] -> CmmLoad (vectorSlot info conZ) wordRep ) + ] + +-- we understand a subset of C-- primitives: +machOps = listToUFM $ + map (\(x, y) -> (mkFastString x, y)) [ + ( "add", MO_Add ), + ( "sub", MO_Sub ), + ( "eq", MO_Eq ), + ( "ne", MO_Ne ), + ( "mul", MO_Mul ), + ( "neg", MO_S_Neg ), + ( "quot", MO_S_Quot ), + ( "rem", MO_S_Rem ), + ( "divu", MO_U_Quot ), + ( "modu", MO_U_Rem ), + + ( "ge", MO_S_Ge ), + ( "le", MO_S_Le ), + ( "gt", MO_S_Gt ), + ( "lt", MO_S_Lt ), + + ( "geu", MO_U_Ge ), + ( "leu", MO_U_Le ), + ( "gtu", MO_U_Gt ), + ( "ltu", MO_U_Lt ), + + ( "flt", MO_S_Lt ), + ( "fle", MO_S_Le ), + ( "feq", MO_Eq ), + ( "fne", MO_Ne ), + ( "fgt", MO_S_Gt ), + ( "fge", MO_S_Ge ), + ( "fneg", MO_S_Neg ), + + ( "and", MO_And ), + ( "or", MO_Or ), + ( "xor", MO_Xor ), + ( "com", MO_Not ), + ( "shl", MO_Shl ), + ( "shrl", MO_U_Shr ), + ( "shra", MO_S_Shr ), + + ( "lobits8", flip MO_U_Conv I8 ), + ( "lobits16", flip MO_U_Conv I16 ), + ( "lobits32", flip MO_U_Conv I32 ), + ( "lobits64", flip MO_U_Conv I64 ), + ( "sx16", flip MO_S_Conv I16 ), + ( "sx32", flip MO_S_Conv I32 ), + ( "sx64", flip MO_S_Conv I64 ), + ( "zx16", flip MO_U_Conv I16 ), + ( "zx32", flip MO_U_Conv I32 ), + ( "zx64", flip MO_U_Conv I64 ), + ( "f2f32", flip MO_S_Conv F32 ), -- TODO; rounding mode + ( "f2f64", flip MO_S_Conv F64 ), -- TODO; rounding mode + ( "f2i8", flip MO_S_Conv I8 ), + ( "f2i16", flip MO_S_Conv I8 ), + ( "f2i32", flip MO_S_Conv I8 ), + ( "f2i64", flip MO_S_Conv I8 ), + ( "i2f32", flip MO_S_Conv F32 ), + ( "i2f64", flip MO_S_Conv F64 ) + ] + +parseHint :: String -> P MachHint +parseHint "ptr" = return PtrHint +parseHint "signed" = return SignedHint +parseHint "float" = return FloatHint +parseHint str = fail ("unrecognised hint: " ++ str) + +-- labels are always pointers, so we might as well infer the hint +inferHint :: CmmExpr -> MachHint +inferHint (CmmLit (CmmLabel _)) = PtrHint +inferHint (CmmReg (CmmGlobal g)) | isPtrGlobalReg g = PtrHint +inferHint _ = NoHint + +isPtrGlobalReg Sp = True +isPtrGlobalReg SpLim = True +isPtrGlobalReg Hp = True +isPtrGlobalReg HpLim = True +isPtrGlobalReg CurrentTSO = True +isPtrGlobalReg CurrentNursery = True +isPtrGlobalReg _ = False + +happyError :: P a +happyError = srcParseFail + +-- ----------------------------------------------------------------------------- +-- Statement-level macros + +stmtMacro :: FastString -> [ExtFCode CmmExpr] -> P ExtCode +stmtMacro fun args_code = do + case lookupUFM stmtMacros fun of + Nothing -> fail ("unknown macro: " ++ unpackFS fun) + Just fcode -> return $ do + args <- sequence args_code + code (fcode args) + +stmtMacros :: UniqFM ([CmmExpr] -> Code) +stmtMacros = listToUFM [ + ( FSLIT("CCS_ALLOC"), \[words,ccs] -> profAlloc words ccs ), + ( FSLIT("CLOSE_NURSERY"), \[] -> emitCloseNursery ), + ( FSLIT("ENTER_CCS_PAP_CL"), \[e] -> enterCostCentrePAP e ), + ( FSLIT("ENTER_CCS_THUNK"), \[e] -> enterCostCentreThunk e ), + ( FSLIT("HP_CHK_GEN"), \[words,liveness,reentry] -> + hpChkGen words liveness reentry ), + ( FSLIT("HP_CHK_NP_ASSIGN_SP0"), \[e,f] -> hpChkNodePointsAssignSp0 e f ), + ( FSLIT("LOAD_THREAD_STATE"), \[] -> emitLoadThreadState ), + ( FSLIT("LDV_ENTER"), \[e] -> ldvEnter e ), + ( FSLIT("LDV_RECORD_CREATE"), \[e] -> ldvRecordCreate e ), + ( FSLIT("OPEN_NURSERY"), \[] -> emitOpenNursery ), + ( FSLIT("PUSH_UPD_FRAME"), \[sp,e] -> emitPushUpdateFrame sp e ), + ( FSLIT("SAVE_THREAD_STATE"), \[] -> emitSaveThreadState ), + ( FSLIT("SET_HDR"), \[ptr,info,ccs] -> + emitSetDynHdr ptr info ccs ), + ( FSLIT("STK_CHK_GEN"), \[words,liveness,reentry] -> + stkChkGen words liveness reentry ), + ( FSLIT("STK_CHK_NP"), \[e] -> stkChkNodePoints e ), + ( FSLIT("TICK_ALLOC_PRIM"), \[hdr,goods,slop] -> + tickyAllocPrim hdr goods slop ), + ( FSLIT("TICK_ALLOC_PAP"), \[goods,slop] -> + tickyAllocPAP goods slop ), + ( FSLIT("TICK_ALLOC_UP_THK"), \[goods,slop] -> + tickyAllocThunk goods slop ), + ( FSLIT("UPD_BH_UPDATABLE"), \[] -> emitBlackHoleCode False ), + ( FSLIT("UPD_BH_SINGLE_ENTRY"), \[] -> emitBlackHoleCode True ), + + ( FSLIT("RET_P"), \[a] -> emitRetUT [(PtrArg,a)]), + ( FSLIT("RET_N"), \[a] -> emitRetUT [(NonPtrArg,a)]), + ( FSLIT("RET_PP"), \[a,b] -> emitRetUT [(PtrArg,a),(PtrArg,b)]), + ( FSLIT("RET_NN"), \[a,b] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b)]), + ( FSLIT("RET_NP"), \[a,b] -> emitRetUT [(NonPtrArg,a),(PtrArg,b)]), + ( FSLIT("RET_PPP"), \[a,b,c] -> emitRetUT [(PtrArg,a),(PtrArg,b),(PtrArg,c)]), + ( FSLIT("RET_NNP"), \[a,b,c] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(PtrArg,c)]), + ( FSLIT("RET_NNNP"), \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c),(PtrArg,d)]), + ( FSLIT("RET_NPNP"), \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(PtrArg,b),(NonPtrArg,c),(PtrArg,d)]) + + ] + +-- ----------------------------------------------------------------------------- +-- Our extended FCode monad. + +-- We add a mapping from names to CmmExpr, to support local variable names in +-- the concrete C-- code. The unique supply of the underlying FCode monad +-- is used to grab a new unique for each local variable. + +-- In C--, a local variable can be declared anywhere within a proc, +-- and it scopes from the beginning of the proc to the end. Hence, we have +-- to collect declarations as we parse the proc, and feed the environment +-- back in circularly (to avoid a two-pass algorithm). + +type Decls = [(FastString,CmmExpr)] +type Env = UniqFM CmmExpr + +newtype ExtFCode a = EC { unEC :: Env -> Decls -> FCode (Decls, a) } + +type ExtCode = ExtFCode () + +returnExtFC a = EC $ \e s -> return (s, a) +thenExtFC (EC m) k = EC $ \e s -> do (s',r) <- m e s; unEC (k r) e s' + +instance Monad ExtFCode where + (>>=) = thenExtFC + return = returnExtFC + +-- This function takes the variable decarations and imports and makes +-- an environment, which is looped back into the computation. In this +-- way, we can have embedded declarations that scope over the whole +-- procedure, and imports that scope over the entire module. +loopDecls :: ExtFCode a -> ExtFCode a +loopDecls (EC fcode) = + EC $ \e s -> fixC (\ ~(decls,a) -> fcode (addListToUFM e decls) []) + +getEnv :: ExtFCode Env +getEnv = EC $ \e s -> return (s, e) + +addVarDecl :: FastString -> CmmExpr -> ExtCode +addVarDecl var expr = EC $ \e s -> return ((var,expr):s, ()) + +newLocal :: MachRep -> FastString -> ExtCode +newLocal ty name = do + u <- code newUnique + addVarDecl name (CmmReg (CmmLocal (LocalReg u ty))) + +-- Unknown names are treated as if they had been 'import'ed. +-- This saves us a lot of bother in the RTS sources, at the expense of +-- deferring some errors to link time. +lookupName :: FastString -> ExtFCode CmmExpr +lookupName name = do + env <- getEnv + return $ + case lookupUFM env name of + Nothing -> CmmLit (CmmLabel (mkRtsCodeLabelFS name)) + Just e -> e + +-- Lifting FCode computations into the ExtFCode monad: +code :: FCode a -> ExtFCode a +code fc = EC $ \e s -> do r <- fc; return (s, r) + +code2 :: (FCode (Decls,b) -> FCode ((Decls,b),c)) + -> ExtFCode b -> ExtFCode c +code2 f (EC ec) = EC $ \e s -> do ((s',b),c) <- f (ec e s); return (s',c) + +nopEC = code nopC +stmtEC stmt = code (stmtC stmt) +stmtsEC stmts = code (stmtsC stmts) +getCgStmtsEC = code2 getCgStmts' + +forkLabelledCodeEC ec = do + stmts <- getCgStmtsEC ec + code (forkCgStmts stmts) + +retInfo name size live_bits cl_type vector = do + let liveness = smallLiveness (fromIntegral size) (fromIntegral live_bits) + (info1,info2) = mkRetInfoTable liveness NoC_SRT + (fromIntegral cl_type) vector + return (mkRtsRetInfoLabelFS name, info1, info2) + +stdInfo name ptrs nptrs srt_bitmap cl_type desc_str ty_str = + basicInfo name (packHalfWordsCLit ptrs nptrs) + srt_bitmap cl_type desc_str ty_str + +basicInfo name layout srt_bitmap cl_type desc_str ty_str = do + lit1 <- if opt_SccProfilingOn + then code $ mkStringCLit desc_str + else return (mkIntCLit 0) + lit2 <- if opt_SccProfilingOn + then code $ mkStringCLit ty_str + else return (mkIntCLit 0) + let info1 = mkStdInfoTable lit1 lit2 (fromIntegral cl_type) + (fromIntegral srt_bitmap) + layout + return (mkRtsInfoLabelFS name, info1, []) + +funInfo name ptrs nptrs cl_type desc_str ty_str fun_type = do + (label,info1,_) <- stdInfo name ptrs nptrs 0{-srt_bitmap-} + cl_type desc_str ty_str + let info2 = mkFunGenInfoExtraBits (fromIntegral fun_type) 0 zero zero zero + -- we leave most of the fields zero here. This is only used + -- to generate the BCO info table in the RTS at the moment. + return (label,info1,info2) + where + zero = mkIntCLit 0 + + +staticClosure :: FastString -> FastString -> [CmmLit] -> ExtCode +staticClosure cl_label info payload + = code $ emitDataLits (mkRtsDataLabelFS cl_label) lits + where lits = mkStaticClosure (mkRtsInfoLabelFS info) dontCareCCS payload [] [] + +foreignCall + :: String + -> [ExtFCode (CmmReg,MachHint)] + -> ExtFCode CmmExpr + -> [ExtFCode (CmmExpr,MachHint)] + -> Maybe [GlobalReg] -> P ExtCode +foreignCall "C" results_code expr_code args_code vols + = return $ do + results <- sequence results_code + expr <- expr_code + args <- sequence args_code + stmtEC (CmmCall (CmmForeignCall expr CCallConv) results args vols) +foreignCall conv _ _ _ _ + = fail ("unknown calling convention: " ++ conv) + +doStore :: MachRep -> ExtFCode CmmExpr -> ExtFCode CmmExpr -> ExtCode +doStore rep addr_code val_code + = do addr <- addr_code + val <- val_code + -- if the specified store type does not match the type of the expr + -- on the rhs, then we insert a coercion that will cause the type + -- mismatch to be flagged by cmm-lint. If we don't do this, then + -- the store will happen at the wrong type, and the error will not + -- be noticed. + let coerce_val + | cmmExprRep val /= rep = CmmMachOp (MO_U_Conv rep rep) [val] + | otherwise = val + stmtEC (CmmStore addr coerce_val) + +-- Return an unboxed tuple. +emitRetUT :: [(CgRep,CmmExpr)] -> Code +emitRetUT args = do + tickyUnboxedTupleReturn (length args) -- TICK + (sp, stmts) <- pushUnboxedTuple 0 args + emitStmts stmts + when (sp /= 0) $ stmtC (CmmAssign spReg (cmmRegOffW spReg (-sp))) + stmtC (CmmJump (entryCode (CmmLoad (cmmRegOffW spReg sp) wordRep)) []) + +-- ----------------------------------------------------------------------------- +-- If-then-else and boolean expressions + +data BoolExpr + = BoolExpr `BoolAnd` BoolExpr + | BoolExpr `BoolOr` BoolExpr + | BoolNot BoolExpr + | BoolTest CmmExpr + +-- ToDo: smart constructors which simplify the boolean expression. + +ifThenElse cond then_part else_part = do + then_id <- code newLabelC + join_id <- code newLabelC + c <- cond + emitCond c then_id + else_part + stmtEC (CmmBranch join_id) + code (labelC then_id) + then_part + -- fall through to join + code (labelC join_id) + +-- 'emitCond cond true_id' emits code to test whether the cond is true, +-- branching to true_id if so, and falling through otherwise. +emitCond (BoolTest e) then_id = do + stmtEC (CmmCondBranch e then_id) +emitCond (BoolNot (BoolTest (CmmMachOp op args))) then_id + | Just op' <- maybeInvertComparison op + = emitCond (BoolTest (CmmMachOp op' args)) then_id +emitCond (BoolNot e) then_id = do + else_id <- code newLabelC + emitCond e else_id + stmtEC (CmmBranch then_id) + code (labelC else_id) +emitCond (e1 `BoolOr` e2) then_id = do + emitCond e1 then_id + emitCond e2 then_id +emitCond (e1 `BoolAnd` e2) then_id = do + -- we'd like to invert one of the conditionals here to avoid an + -- extra branch instruction, but we can't use maybeInvertComparison + -- here because we can't look too closely at the expression since + -- we're in a loop. + and_id <- code newLabelC + else_id <- code newLabelC + emitCond e1 and_id + stmtEC (CmmBranch else_id) + code (labelC and_id) + emitCond e2 then_id + code (labelC else_id) + + +-- ----------------------------------------------------------------------------- +-- Table jumps + +-- We use a simplified form of C-- switch statements for now. A +-- switch statement always compiles to a table jump. Each arm can +-- specify a list of values (not ranges), and there can be a single +-- default branch. The range of the table is given either by the +-- optional range on the switch (eg. switch [0..7] {...}), or by +-- the minimum/maximum values from the branches. + +doSwitch :: Maybe (Int,Int) -> ExtFCode CmmExpr -> [([Int],ExtCode)] + -> Maybe ExtCode -> ExtCode +doSwitch mb_range scrut arms deflt + = do + -- Compile code for the default branch + dflt_entry <- + case deflt of + Nothing -> return Nothing + Just e -> do b <- forkLabelledCodeEC e; return (Just b) + + -- Compile each case branch + table_entries <- mapM emitArm arms + + -- Construct the table + let + all_entries = concat table_entries + ixs = map fst all_entries + (min,max) + | Just (l,u) <- mb_range = (l,u) + | otherwise = (minimum ixs, maximum ixs) + + entries = elems (accumArray (\_ a -> Just a) dflt_entry (min,max) + all_entries) + expr <- scrut + -- ToDo: check for out of range and jump to default if necessary + stmtEC (CmmSwitch expr entries) + where + emitArm :: ([Int],ExtCode) -> ExtFCode [(Int,BlockId)] + emitArm (ints,code) = do + blockid <- forkLabelledCodeEC code + return [ (i,blockid) | i <- ints ] + + +-- ----------------------------------------------------------------------------- +-- Putting it all together + +-- The initial environment: we define some constants that the compiler +-- knows about here. +initEnv :: Env +initEnv = listToUFM [ + ( FSLIT("SIZEOF_StgHeader"), + CmmLit (CmmInt (fromIntegral (fixedHdrSize * wORD_SIZE)) wordRep) ) + ] + +parseCmmFile :: DynFlags -> FilePath -> IO (Maybe Cmm) +parseCmmFile dflags filename = do + showPass dflags "ParseCmm" + buf <- hGetStringBuffer filename + let + init_loc = mkSrcLoc (mkFastString filename) 1 0 + init_state = (mkPState buf init_loc dflags) { lex_state = [0] } + -- reset the lex_state: the Lexer monad leaves some stuff + -- in there we don't want. + case unP cmmParse init_state of + PFailed span err -> do printError span err; return Nothing + POk _ code -> do + cmm <- initC no_module (getCmm (unEC code initEnv [] >> return ())) + dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms [cmm]) + return (Just cmm) + where + no_module = panic "parseCmmFile: no module" + +} diff --git a/ghc/compiler/cmm/CmmUtils.hs b/ghc/compiler/cmm/CmmUtils.hs new file mode 100644 index 0000000000..b2a107c1cc --- /dev/null +++ b/ghc/compiler/cmm/CmmUtils.hs @@ -0,0 +1,169 @@ +----------------------------------------------------------------------------- +-- +-- Cmm utilities. +-- +-- (c) The University of Glasgow 2004 +-- +----------------------------------------------------------------------------- + +module CmmUtils( + CmmStmts, noStmts, oneStmt, mkStmts, plusStmts, stmtList, + isNopStmt, + + isTrivialCmmExpr, + + cmmRegOff, cmmLabelOff, cmmOffset, cmmOffsetLit, cmmIndex, + cmmOffsetExpr, cmmIndexExpr, cmmLoadIndex, + + mkIntCLit, zeroCLit, + + mkLblExpr, + ) where + +#include "HsVersions.h" + +import CLabel ( CLabel ) +import Cmm +import MachOp +import OrdList +import Outputable + +--------------------------------------------------- +-- +-- CmmStmts +-- +--------------------------------------------------- + +type CmmStmts = OrdList CmmStmt + +noStmts :: CmmStmts +noStmts = nilOL + +oneStmt :: CmmStmt -> CmmStmts +oneStmt = unitOL + +mkStmts :: [CmmStmt] -> CmmStmts +mkStmts = toOL + +plusStmts :: CmmStmts -> CmmStmts -> CmmStmts +plusStmts = appOL + +stmtList :: CmmStmts -> [CmmStmt] +stmtList = fromOL + + +--------------------------------------------------- +-- +-- CmmStmt +-- +--------------------------------------------------- + +isNopStmt :: CmmStmt -> Bool +-- If isNopStmt returns True, the stmt is definitely a no-op; +-- but it might be a no-op even if isNopStmt returns False +isNopStmt CmmNop = True +isNopStmt (CmmAssign r e) = cheapEqReg r e +isNopStmt (CmmStore e1 (CmmLoad e2 _)) = cheapEqExpr e1 e2 +isNopStmt s = False + +cheapEqExpr :: CmmExpr -> CmmExpr -> Bool +cheapEqExpr (CmmReg r) e = cheapEqReg r e +cheapEqExpr (CmmRegOff r 0) e = cheapEqReg r e +cheapEqExpr (CmmRegOff r n) (CmmRegOff r' n') = r==r' && n==n' +cheapEqExpr e1 e2 = False + +cheapEqReg :: CmmReg -> CmmExpr -> Bool +cheapEqReg r (CmmReg r') = r==r' +cheapEqReg r (CmmRegOff r' 0) = r==r' +cheapEqReg r e = False + +--------------------------------------------------- +-- +-- CmmExpr +-- +--------------------------------------------------- + +isTrivialCmmExpr :: CmmExpr -> Bool +isTrivialCmmExpr (CmmLoad _ _) = False +isTrivialCmmExpr (CmmMachOp _ _) = False +isTrivialCmmExpr (CmmLit _) = True +isTrivialCmmExpr (CmmReg _) = True +isTrivialCmmExpr (CmmRegOff _ _) = True + +--------------------------------------------------- +-- +-- Expr Construction helpers +-- +--------------------------------------------------- + +cmmOffsetExpr :: CmmExpr -> CmmExpr -> CmmExpr +-- assumes base and offset have the same MachRep +cmmOffsetExpr e (CmmLit (CmmInt n _)) = cmmOffset e (fromInteger n) +cmmOffsetExpr e byte_off = CmmMachOp (MO_Add (cmmExprRep e)) [e, byte_off] + +-- NB. Do *not* inspect the value of the offset in these smart constructors!!! +-- +-- because the offset is sometimes involved in a loop in the code generator +-- (we don't know the real Hp offset until we've generated code for the entire +-- basic block, for example). So we cannot eliminate zero offsets at this +-- stage; they're eliminated later instead (either during printing or +-- a later optimisation step on Cmm). +-- +cmmOffset :: CmmExpr -> Int -> CmmExpr +cmmOffset (CmmReg reg) byte_off = cmmRegOff reg byte_off +cmmOffset (CmmRegOff reg m) byte_off = cmmRegOff reg (m+byte_off) +cmmOffset (CmmLit lit) byte_off = CmmLit (cmmOffsetLit lit byte_off) +cmmOffset (CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt byte_off1 _rep)]) byte_off2 + = CmmMachOp (MO_Add rep) + [expr, CmmLit (CmmInt (byte_off1 + toInteger byte_off2) rep)] +cmmOffset expr byte_off + = CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt (toInteger byte_off) rep)] + where + rep = cmmExprRep expr + +-- Smart constructor for CmmRegOff. Same caveats as cmmOffset above. +cmmRegOff :: CmmReg -> Int -> CmmExpr +cmmRegOff reg byte_off = CmmRegOff reg byte_off + +cmmOffsetLit :: CmmLit -> Int -> CmmLit +cmmOffsetLit (CmmLabel l) byte_off = cmmLabelOff l byte_off +cmmOffsetLit (CmmLabelOff l m) byte_off = cmmLabelOff l (m+byte_off) +cmmOffsetLit (CmmInt m rep) byte_off = CmmInt (m + fromIntegral byte_off) rep +cmmOffsetLit other byte_off = pprPanic "cmmOffsetLit" (ppr byte_off) + +cmmLabelOff :: CLabel -> Int -> CmmLit +-- Smart constructor for CmmLabelOff +cmmLabelOff lbl 0 = CmmLabel lbl +cmmLabelOff lbl byte_off = CmmLabelOff lbl byte_off + +-- | Useful for creating an index into an array, with a staticaly known offset. +cmmIndex :: MachRep -> CmmExpr -> Int -> CmmExpr +cmmIndex rep base idx = cmmOffset base (idx * machRepByteWidth rep) + +-- | Useful for creating an index into an array, with an unknown offset. +cmmIndexExpr :: MachRep -> CmmExpr -> CmmExpr -> CmmExpr +cmmIndexExpr rep base (CmmLit (CmmInt n _)) = cmmIndex rep base (fromInteger n) +cmmIndexExpr rep base idx = + cmmOffsetExpr base byte_off + where + idx_rep = cmmExprRep idx + byte_off = CmmMachOp (MO_Shl idx_rep) [ + idx, CmmLit (mkIntCLit (machRepLogWidth rep))] + +cmmLoadIndex :: MachRep -> CmmExpr -> Int -> CmmExpr +cmmLoadIndex rep expr ix = CmmLoad (cmmIndex rep expr ix) rep + +--------------------------------------------------- +-- +-- Literal construction functions +-- +--------------------------------------------------- + +mkIntCLit :: Int -> CmmLit +mkIntCLit i = CmmInt (toInteger i) wordRep + +zeroCLit :: CmmLit +zeroCLit = CmmInt 0 wordRep + +mkLblExpr :: CLabel -> CmmExpr +mkLblExpr lbl = CmmLit (CmmLabel lbl) diff --git a/ghc/compiler/cmm/MachOp.hs b/ghc/compiler/cmm/MachOp.hs new file mode 100644 index 0000000000..55aaa3e7ec --- /dev/null +++ b/ghc/compiler/cmm/MachOp.hs @@ -0,0 +1,632 @@ +----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow 2002-2004 +-- +-- Low-level machine operations, used in the Cmm datatype. +-- +----------------------------------------------------------------------------- + +module MachOp ( + MachRep(..), + machRepBitWidth, + machRepByteWidth, + machRepLogWidth, + isFloatingRep, + + MachHint(..), + + MachOp(..), + pprMachOp, + isCommutableMachOp, + isComparisonMachOp, + resultRepOfMachOp, + machOpArgReps, + maybeInvertComparison, + + CallishMachOp(..), + pprCallishMachOp, + + wordRep, + halfWordRep, + cIntRep, cLongRep, + + mo_wordAdd, + mo_wordSub, + mo_wordEq, + mo_wordNe, + mo_wordMul, + mo_wordSQuot, + mo_wordSRem, + mo_wordSNeg, + mo_wordUQuot, + mo_wordURem, + + mo_wordSGe, + mo_wordSLe, + mo_wordSGt, + mo_wordSLt, + + mo_wordUGe, + mo_wordULe, + mo_wordUGt, + mo_wordULt, + + mo_wordAnd, + mo_wordOr, + mo_wordXor, + mo_wordNot, + mo_wordShl, + mo_wordSShr, + mo_wordUShr, + + mo_u_8To32, + mo_s_8To32, + mo_u_16To32, + mo_s_16To32, + + mo_u_8ToWord, + mo_s_8ToWord, + mo_u_16ToWord, + mo_s_16ToWord, + mo_u_32ToWord, + mo_s_32ToWord, + + mo_32To8, + mo_32To16, + mo_WordTo8, + mo_WordTo16, + mo_WordTo32, + ) where + +#include "HsVersions.h" +#include "../includes/ghcconfig.h" + +import Constants +import Outputable + +-- ----------------------------------------------------------------------------- +-- MachRep + +{- | +A MachRep is the "representation" of a value in Cmm. It is used for +resource allocation: eg. which kind of register a value should be +stored in. + +The primary requirement is that there exists a function + + cmmExprRep :: CmmExpr -> MachRep + +This means that: + + - a register has an implicit MachRep + - a literal has an implicit MachRep + - an operation (MachOp) has an implicit result MachRep + +It also means that we can check that the arguments to a MachOp have +the correct MachRep, i.e. we can do a kind of lint-style type checking +on Cmm. +-} + +data MachRep + = I8 + | I16 + | I32 + | I64 + | I128 + | F32 + | F64 + | F80 -- extended double-precision, used in x86 native codegen only. + deriving (Eq, Ord, Show) + +mrStr I8 = SLIT("I8") +mrStr I16 = SLIT("I16") +mrStr I32 = SLIT("I32") +mrStr I64 = SLIT("I64") +mrStr I128 = SLIT("I128") +mrStr F32 = SLIT("F32") +mrStr F64 = SLIT("F64") +mrStr F80 = SLIT("F80") + +instance Outputable MachRep where + ppr rep = ptext (mrStr rep) + +{- +Implementation notes: + +It might suffice to keep just a width, without distinguishing between +floating and integer types. However, keeping the distinction will +help the native code generator to assign registers more easily. +-} + +{- +Should a MachRep include a signed vs. unsigned distinction? + +This is very much like a "hint" in C-- terminology: it isn't necessary +in order to generate correct code, but it might be useful in that the +compiler can generate better code if it has access to higher-level +hints about data. This is important at call boundaries, because the +definition of a function is not visible at all of its call sites, so +the compiler cannot infer the hints. + +Here in Cmm, we're taking a slightly different approach. We include +the int vs. float hint in the MachRep, because (a) the majority of +platforms have a strong distinction between float and int registers, +and (b) we don't want to do any heavyweight hint-inference in the +native code backend in order to get good code. We're treating the +hint more like a type: our Cmm is always completely consistent with +respect to hints. All coercions between float and int are explicit. + +What about the signed vs. unsigned hint? This information might be +useful if we want to keep sub-word-sized values in word-size +registers, which we must do if we only have word-sized registers. + +On such a system, there are two straightforward conventions for +representing sub-word-sized values: + +(a) Leave the upper bits undefined. Comparison operations must + sign- or zero-extend both operands before comparing them, + depending on whether the comparison is signed or unsigned. + +(b) Always keep the values sign- or zero-extended as appropriate. + Arithmetic operations must narrow the result to the appropriate + size. + +A clever compiler might not use either (a) or (b) exclusively, instead +it would attempt to minimize the coercions by analysis: the same kind +of analysis that propagates hints around. In Cmm we don't want to +have to do this, so we plump for having richer types and keeping the +type information consistent. + +If signed/unsigned hints are missing from MachRep, then the only +choice we have is (a), because we don't know whether the result of an +operation should be sign- or zero-extended. + +Many architectures have extending load operations, which work well +with (b). To make use of them with (a), you need to know whether the +value is going to be sign- or zero-extended by an enclosing comparison +(for example), which involves knowing above the context. This is +doable but more complex. + +Further complicating the issue is foreign calls: a foreign calling +convention can specify that signed 8-bit quantities are passed as +sign-extended 32 bit quantities, for example (this is the case on the +PowerPC). So we *do* need sign information on foreign call arguments. + +Pros for adding signed vs. unsigned to MachRep: + + - It would let us use convention (b) above, and get easier + code generation for extending loads. + + - Less information required on foreign calls. + + - MachOp type would be simpler + +Cons: + + - More complexity + + - What is the MachRep for a VanillaReg? Currently it is + always wordRep, but now we have to decide whether it is + signed or unsigned. The same VanillaReg can thus have + different MachReps in different parts of the program. + + - Extra coercions cluttering up expressions. + +Currently for GHC, the foreign call point is moot, because we do our +own promotion of sub-word-sized values to word-sized values. The Int8 +type is represnted by an Int# which is kept sign-extended at all times +(this is slightly naughty, because we're making assumptions about the +C calling convention rather early on in the compiler). However, given +this, the cons outweigh the pros. + +-} + + +machRepBitWidth :: MachRep -> Int +machRepBitWidth I8 = 8 +machRepBitWidth I16 = 16 +machRepBitWidth I32 = 32 +machRepBitWidth I64 = 64 +machRepBitWidth I128 = 128 +machRepBitWidth F32 = 32 +machRepBitWidth F64 = 64 +machRepBitWidth F80 = 80 + +machRepByteWidth :: MachRep -> Int +machRepByteWidth I8 = 1 +machRepByteWidth I16 = 2 +machRepByteWidth I32 = 4 +machRepByteWidth I64 = 8 +machRepByteWidth I128 = 16 +machRepByteWidth F32 = 4 +machRepByteWidth F64 = 8 +machRepByteWidth F80 = 10 + +-- log_2 of the width in bytes, useful for generating shifts. +machRepLogWidth :: MachRep -> Int +machRepLogWidth I8 = 0 +machRepLogWidth I16 = 1 +machRepLogWidth I32 = 2 +machRepLogWidth I64 = 3 +machRepLogWidth I128 = 4 +machRepLogWidth F32 = 2 +machRepLogWidth F64 = 3 +machRepLogWidth F80 = panic "machRepLogWidth: F80" + +isFloatingRep :: MachRep -> Bool +isFloatingRep F32 = True +isFloatingRep F64 = True +isFloatingRep F80 = True +isFloatingRep _ = False + +-- ----------------------------------------------------------------------------- +-- Hints + +{- +A hint gives a little more information about a data value. Hints are +used on the arguments to a foreign call, where the code generator needs +to know some extra information on top of the MachRep of each argument in +order to generate a correct call. +-} + +data MachHint + = NoHint + | PtrHint + | SignedHint + | FloatHint + deriving Eq + +mhStr NoHint = SLIT("NoHint") +mhStr PtrHint = SLIT("PtrHint") +mhStr SignedHint = SLIT("SignedHint") +mhStr FloatHint = SLIT("FloatHint") + +instance Outputable MachHint where + ppr hint = ptext (mhStr hint) + +-- ----------------------------------------------------------------------------- +-- MachOp + +{- | +Machine-level primops; ones which we can reasonably delegate to the +native code generators to handle. Basically contains C's primops +and no others. + +Nomenclature: all ops indicate width and signedness, where +appropriate. Widths: 8\/16\/32\/64 means the given size, obviously. +Nat means the operation works on STG word sized objects. +Signedness: S means signed, U means unsigned. For operations where +signedness is irrelevant or makes no difference (for example +integer add), the signedness component is omitted. + +An exception: NatP is a ptr-typed native word. From the point of +view of the native code generators this distinction is irrelevant, +but the C code generator sometimes needs this info to emit the +right casts. +-} + +data MachOp + + -- Integer operations + = MO_Add MachRep + | MO_Sub MachRep + | MO_Eq MachRep + | MO_Ne MachRep + | MO_Mul MachRep -- low word of multiply + | MO_S_MulMayOflo MachRep -- nonzero if signed multiply overflows + | MO_S_Quot MachRep -- signed / (same semantics as IntQuotOp) + | MO_S_Rem MachRep -- signed % (same semantics as IntRemOp) + | MO_S_Neg MachRep -- unary - + | MO_U_MulMayOflo MachRep -- nonzero if unsigned multiply overflows + | MO_U_Quot MachRep -- unsigned / (same semantics as WordQuotOp) + | MO_U_Rem MachRep -- unsigned % (same semantics as WordRemOp) + + -- Signed comparisons (floating-point comparisons also use these) + | MO_S_Ge MachRep + | MO_S_Le MachRep + | MO_S_Gt MachRep + | MO_S_Lt MachRep + + -- Unsigned comparisons + | MO_U_Ge MachRep + | MO_U_Le MachRep + | MO_U_Gt MachRep + | MO_U_Lt MachRep + + -- Bitwise operations. Not all of these may be supported at all sizes, + -- and only integral MachReps are valid. + | MO_And MachRep + | MO_Or MachRep + | MO_Xor MachRep + | MO_Not MachRep + | MO_Shl MachRep + | MO_U_Shr MachRep -- unsigned shift right + | MO_S_Shr MachRep -- signed shift right + + -- Conversions. Some of these will be NOPs. + -- Floating-point conversions use the signed variant. + | MO_S_Conv MachRep{-from-} MachRep{-to-} -- signed conversion + | MO_U_Conv MachRep{-from-} MachRep{-to-} -- unsigned conversion + + deriving (Eq, Show) + +pprMachOp :: MachOp -> SDoc +pprMachOp mo = text (show mo) + + +-- These MachOps tend to be implemented by foreign calls in some backends, +-- so we separate them out. In Cmm, these can only occur in a +-- statement position, in contrast to an ordinary MachOp which can occur +-- anywhere in an expression. +data CallishMachOp + = MO_F64_Pwr + | MO_F64_Sin + | MO_F64_Cos + | MO_F64_Tan + | MO_F64_Sinh + | MO_F64_Cosh + | MO_F64_Tanh + | MO_F64_Asin + | MO_F64_Acos + | MO_F64_Atan + | MO_F64_Log + | MO_F64_Exp + | MO_F64_Sqrt + | MO_F32_Pwr + | MO_F32_Sin + | MO_F32_Cos + | MO_F32_Tan + | MO_F32_Sinh + | MO_F32_Cosh + | MO_F32_Tanh + | MO_F32_Asin + | MO_F32_Acos + | MO_F32_Atan + | MO_F32_Log + | MO_F32_Exp + | MO_F32_Sqrt + deriving (Eq, Show) + +pprCallishMachOp :: CallishMachOp -> SDoc +pprCallishMachOp mo = text (show mo) + +-- ----------------------------------------------------------------------------- +-- Some common MachReps + +-- A 'wordRep' is a machine word on the target architecture +-- Specifically, it is the size of an Int#, Word#, Addr# +-- and the unit of allocation on the stack and the heap +-- Any pointer is also guaranteed to be a wordRep. + +wordRep | wORD_SIZE == 4 = I32 + | wORD_SIZE == 8 = I64 + | otherwise = panic "MachOp.wordRep: Unknown word size" + +halfWordRep | wORD_SIZE == 4 = I16 + | wORD_SIZE == 8 = I32 + | otherwise = panic "MachOp.halfWordRep: Unknown word size" + +mo_wordAdd = MO_Add wordRep +mo_wordSub = MO_Sub wordRep +mo_wordEq = MO_Eq wordRep +mo_wordNe = MO_Ne wordRep +mo_wordMul = MO_Mul wordRep +mo_wordSQuot = MO_S_Quot wordRep +mo_wordSRem = MO_S_Rem wordRep +mo_wordSNeg = MO_S_Neg wordRep +mo_wordUQuot = MO_U_Quot wordRep +mo_wordURem = MO_U_Rem wordRep + +mo_wordSGe = MO_S_Ge wordRep +mo_wordSLe = MO_S_Le wordRep +mo_wordSGt = MO_S_Gt wordRep +mo_wordSLt = MO_S_Lt wordRep + +mo_wordUGe = MO_U_Ge wordRep +mo_wordULe = MO_U_Le wordRep +mo_wordUGt = MO_U_Gt wordRep +mo_wordULt = MO_U_Lt wordRep + +mo_wordAnd = MO_And wordRep +mo_wordOr = MO_Or wordRep +mo_wordXor = MO_Xor wordRep +mo_wordNot = MO_Not wordRep +mo_wordShl = MO_Shl wordRep +mo_wordSShr = MO_S_Shr wordRep +mo_wordUShr = MO_U_Shr wordRep + +mo_u_8To32 = MO_U_Conv I8 I32 +mo_s_8To32 = MO_S_Conv I8 I32 +mo_u_16To32 = MO_U_Conv I16 I32 +mo_s_16To32 = MO_S_Conv I16 I32 + +mo_u_8ToWord = MO_U_Conv I8 wordRep +mo_s_8ToWord = MO_S_Conv I8 wordRep +mo_u_16ToWord = MO_U_Conv I16 wordRep +mo_s_16ToWord = MO_S_Conv I16 wordRep +mo_s_32ToWord = MO_S_Conv I32 wordRep +mo_u_32ToWord = MO_U_Conv I32 wordRep + +mo_WordTo8 = MO_U_Conv wordRep I8 +mo_WordTo16 = MO_U_Conv wordRep I16 +mo_WordTo32 = MO_U_Conv wordRep I32 + +mo_32To8 = MO_U_Conv I32 I8 +mo_32To16 = MO_U_Conv I32 I16 + +-- cIntRep is the MachRep for a C-language 'int' +#if SIZEOF_INT == 4 +cIntRep = I32 +#elif SIZEOF_INT == 8 +cIntRep = I64 +#endif + +#if SIZEOF_LONG == 4 +cLongRep = I32 +#elif SIZEOF_LONG == 8 +cLongRep = I64 +#endif + +-- ---------------------------------------------------------------------------- +-- isCommutableMachOp + +{- | +Returns 'True' if the MachOp has commutable arguments. This is used +in the platform-independent Cmm optimisations. + +If in doubt, return 'False'. This generates worse code on the +native routes, but is otherwise harmless. +-} +isCommutableMachOp :: MachOp -> Bool +isCommutableMachOp mop = + case mop of + MO_Add _ -> True + MO_Eq _ -> True + MO_Ne _ -> True + MO_Mul _ -> True + MO_S_MulMayOflo _ -> True + MO_U_MulMayOflo _ -> True + MO_And _ -> True + MO_Or _ -> True + MO_Xor _ -> True + _other -> False + +-- ---------------------------------------------------------------------------- +-- isComparisonMachOp + +{- | +Returns 'True' if the MachOp is a comparison. + +If in doubt, return False. This generates worse code on the +native routes, but is otherwise harmless. +-} +isComparisonMachOp :: MachOp -> Bool +isComparisonMachOp mop = + case mop of + MO_Eq _ -> True + MO_Ne _ -> True + MO_S_Ge _ -> True + MO_S_Le _ -> True + MO_S_Gt _ -> True + MO_S_Lt _ -> True + MO_U_Ge _ -> True + MO_U_Le _ -> True + MO_U_Gt _ -> True + MO_U_Lt _ -> True + _other -> False + +-- ----------------------------------------------------------------------------- +-- Inverting conditions + +-- Sometimes it's useful to be able to invert the sense of a +-- condition. Not all conditional tests are invertible: in +-- particular, floating point conditionals cannot be inverted, because +-- there exist floating-point values which return False for both senses +-- of a condition (eg. !(NaN > NaN) && !(NaN /<= NaN)). + +maybeInvertComparison :: MachOp -> Maybe MachOp +maybeInvertComparison op + = case op of + MO_Eq r | not (isFloatingRep r) -> Just (MO_Ne r) + MO_Ne r | not (isFloatingRep r) -> Just (MO_Eq r) + MO_U_Lt r | not (isFloatingRep r) -> Just (MO_U_Ge r) + MO_U_Gt r | not (isFloatingRep r) -> Just (MO_U_Le r) + MO_U_Le r | not (isFloatingRep r) -> Just (MO_U_Gt r) + MO_U_Ge r | not (isFloatingRep r) -> Just (MO_U_Lt r) + MO_S_Lt r | not (isFloatingRep r) -> Just (MO_S_Ge r) + MO_S_Gt r | not (isFloatingRep r) -> Just (MO_S_Le r) + MO_S_Le r | not (isFloatingRep r) -> Just (MO_S_Gt r) + MO_S_Ge r | not (isFloatingRep r) -> Just (MO_S_Lt r) + _other -> Nothing + +-- ---------------------------------------------------------------------------- +-- resultRepOfMachOp + +{- | +Returns the MachRep of the result of a MachOp. +-} +resultRepOfMachOp :: MachOp -> MachRep +resultRepOfMachOp mop = + case mop of + MO_Add r -> r + MO_Sub r -> r + MO_Eq r -> comparisonResultRep + MO_Ne r -> comparisonResultRep + MO_Mul r -> r + MO_S_MulMayOflo r -> r + MO_S_Quot r -> r + MO_S_Rem r -> r + MO_S_Neg r -> r + MO_U_MulMayOflo r -> r + MO_U_Quot r -> r + MO_U_Rem r -> r + + MO_S_Ge r -> comparisonResultRep + MO_S_Le r -> comparisonResultRep + MO_S_Gt r -> comparisonResultRep + MO_S_Lt r -> comparisonResultRep + + MO_U_Ge r -> comparisonResultRep + MO_U_Le r -> comparisonResultRep + MO_U_Gt r -> comparisonResultRep + MO_U_Lt r -> comparisonResultRep + + MO_And r -> r + MO_Or r -> r + MO_Xor r -> r + MO_Not r -> r + MO_Shl r -> r + MO_U_Shr r -> r + MO_S_Shr r -> r + + MO_S_Conv from to -> to + MO_U_Conv from to -> to + + +comparisonResultRep = wordRep -- is it? + + +-- ----------------------------------------------------------------------------- +-- machOpArgReps + +-- | This function is used for debugging only: we can check whether an +-- application of a MachOp is "type-correct" by checking that the MachReps of +-- its arguments are the same as the MachOp expects. This is used when +-- linting a CmmExpr. + +machOpArgReps :: MachOp -> [MachRep] +machOpArgReps op = + case op of + MO_Add r -> [r,r] + MO_Sub r -> [r,r] + MO_Eq r -> [r,r] + MO_Ne r -> [r,r] + MO_Mul r -> [r,r] + MO_S_MulMayOflo r -> [r,r] + MO_S_Quot r -> [r,r] + MO_S_Rem r -> [r,r] + MO_S_Neg r -> [r] + MO_U_MulMayOflo r -> [r,r] + MO_U_Quot r -> [r,r] + MO_U_Rem r -> [r,r] + + MO_S_Ge r -> [r,r] + MO_S_Le r -> [r,r] + MO_S_Gt r -> [r,r] + MO_S_Lt r -> [r,r] + + MO_U_Ge r -> [r,r] + MO_U_Le r -> [r,r] + MO_U_Gt r -> [r,r] + MO_U_Lt r -> [r,r] + + MO_And r -> [r,r] + MO_Or r -> [r,r] + MO_Xor r -> [r,r] + MO_Not r -> [r] + MO_Shl r -> [r,wordRep] + MO_U_Shr r -> [r,wordRep] + MO_S_Shr r -> [r,wordRep] + + MO_S_Conv from to -> [from] + MO_U_Conv from to -> [from] diff --git a/ghc/compiler/cmm/PprC.hs b/ghc/compiler/cmm/PprC.hs new file mode 100644 index 0000000000..e7e72abfaa --- /dev/null +++ b/ghc/compiler/cmm/PprC.hs @@ -0,0 +1,958 @@ +----------------------------------------------------------------------------- +-- +-- Pretty-printing of Cmm as C, suitable for feeding gcc +-- +-- (c) The University of Glasgow 2004 +-- +----------------------------------------------------------------------------- + +-- +-- Print Cmm as real C, for -fvia-C +-- +-- This is simpler than the old PprAbsC, because Cmm is "macro-expanded" +-- relative to the old AbstractC, and many oddities/decorations have +-- disappeared from the data type. +-- + +-- ToDo: save/restore volatile registers around calls. + +module PprC ( + writeCs, + pprStringInCStyle + ) where + +#include "HsVersions.h" + +-- Cmm stuff +import Cmm +import CLabel +import MachOp +import ForeignCall + +-- Utils +import Unique ( getUnique ) +import UniqSet +import FiniteMap +import UniqFM ( eltsUFM ) +import FastString +import Outputable +import Constants +import CmdLineOpts ( opt_EnsureSplittableC ) + +-- The rest +import Data.List ( intersperse, group ) +import Data.Bits ( shiftR ) +import Char ( ord, chr ) +import IO ( Handle ) +import DATA_BITS + +#ifdef DEBUG +import PprCmm () -- instances only +-- import Debug.Trace +#endif + +#if __GLASGOW_HASKELL__ >= 504 +import Data.Array.ST +#endif +import MONAD_ST + +-- -------------------------------------------------------------------------- +-- Top level + +pprCs :: [Cmm] -> SDoc +pprCs cmms = pprCode CStyle (vcat $ map (\c -> split_marker $$ pprC c) cmms) + +writeCs :: Handle -> [Cmm] -> IO () +writeCs handle cmms = printForUser handle alwaysQualify (pprCs cmms) + -- ToDo: should be printForC + +split_marker + | opt_EnsureSplittableC = ptext SLIT("__STG_SPLIT_MARKER") + | otherwise = empty + +-- -------------------------------------------------------------------------- +-- Now do some real work +-- +-- for fun, we could call cmmToCmm over the tops... +-- + +pprC :: Cmm -> SDoc +pprC (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops + +-- +-- top level procs +-- +pprTop :: CmmTop -> SDoc +pprTop (CmmProc info clbl _params blocks) = + (if not (null info) + then pprWordArray (entryLblToInfoLbl clbl) info + else empty) $$ + (case blocks of + [] -> empty + -- the first block doesn't get a label: + (BasicBlock _ stmts : rest) -> vcat [ + text "", + extern_decls, + (if (externallyVisibleCLabel clbl) + then mkFN_ else mkIF_) (pprCLabel clbl) <+> lbrace, + nest 8 temp_decls, + nest 8 mkFB_, + nest 8 (vcat (map pprStmt stmts)) $$ + vcat (map pprBBlock rest), + nest 8 mkFE_, + rbrace ] + ) + where + (temp_decls, extern_decls) = pprTempAndExternDecls blocks + + +-- Chunks of static data. + +-- We only handle (a) arrays of word-sized things and (b) strings. + +pprTop (CmmData _section _ds@[CmmDataLabel lbl, CmmString str]) = + hcat [ + pprLocalness lbl, ptext SLIT("char "), pprCLabel lbl, + ptext SLIT("[] = "), pprStringInCStyle str, semi + ] + +pprTop (CmmData _section _ds@[CmmDataLabel lbl, CmmUninitialised size]) = + hcat [ + pprLocalness lbl, ptext SLIT("char "), pprCLabel lbl, + brackets (int size), semi + ] + +pprTop top@(CmmData _section (CmmDataLabel lbl : lits)) = + pprDataExterns lits $$ + pprWordArray lbl lits + +-- these shouldn't appear? +pprTop (CmmData _ _) = panic "PprC.pprTop: can't handle this data" + + +-- -------------------------------------------------------------------------- +-- BasicBlocks are self-contained entities: they always end in a jump. +-- +-- Like nativeGen/AsmCodeGen, we could probably reorder blocks to turn +-- as many jumps as possible into fall throughs. +-- + +pprBBlock :: CmmBasicBlock -> SDoc +pprBBlock (BasicBlock lbl stmts) = + if null stmts then + pprTrace "pprC.pprBBlock: curious empty code block for" + (pprBlockId lbl) empty + else + nest 4 (pprBlockId lbl <> colon) $$ + nest 8 (vcat (map pprStmt stmts)) + +-- -------------------------------------------------------------------------- +-- Info tables. Just arrays of words. +-- See codeGen/ClosureInfo, and nativeGen/PprMach + +pprWordArray :: CLabel -> [CmmStatic] -> SDoc +pprWordArray lbl ds + = hcat [ pprLocalness lbl, ptext SLIT("StgWord") + , space, pprCLabel lbl, ptext SLIT("[] = {") ] + $$ nest 8 (commafy (pprStatics ds)) + $$ ptext SLIT("};") + +-- +-- has to be static, if it isn't globally visible +-- +pprLocalness :: CLabel -> SDoc +pprLocalness lbl | not $ externallyVisibleCLabel lbl = ptext SLIT("static ") + | otherwise = empty + +-- -------------------------------------------------------------------------- +-- Statements. +-- + +pprStmt :: CmmStmt -> SDoc + +pprStmt stmt = case stmt of + CmmNop -> empty + CmmComment s -> (hang (ptext SLIT("/*")) 3 (ftext s)) $$ ptext SLIT("*/") + + CmmAssign dest src -> pprAssign dest src + + CmmStore dest src + | rep == I64 + -> ptext SLIT("ASSIGN_Word64") <> + parens (mkP_ <> pprExpr1 dest <> comma <> pprExpr src) <> semi + + | otherwise + -> hsep [ pprExpr (CmmLoad dest rep), equals, pprExpr src <> semi ] + where + rep = cmmExprRep src + + CmmCall (CmmForeignCall fn cconv) results args volatile -> + -- Controversial: leave this out for now. + -- pprUndef fn $$ + + pprCall ppr_fn cconv results args volatile + where + ppr_fn = case fn of + CmmLit (CmmLabel lbl) -> pprCLabel lbl + _other -> parens (cCast (pprCFunType results args) fn) + -- for a dynamic call, cast the expression to + -- a function of the right type (we hope). + + -- we #undef a function before calling it: the FFI is supposed to be + -- an interface specifically to C, not to C+CPP. For one thing, this + -- makes the via-C route more compatible with the NCG. If macros + -- are being used for optimisation, then inline functions are probably + -- better anyway. + pprUndef (CmmLit (CmmLabel lbl)) = + ptext SLIT("#undef") <+> pprCLabel lbl + pprUndef _ = empty + + CmmCall (CmmPrim op) results args volatile -> + pprCall ppr_fn CCallConv results args volatile + where + ppr_fn = pprCallishMachOp_for_C op + + CmmBranch ident -> pprBranch ident + CmmCondBranch expr ident -> pprCondBranch expr ident + CmmJump lbl _params -> mkJMP_(pprExpr lbl) <> semi + CmmSwitch arg ids -> pprSwitch arg ids + +pprCFunType :: [(CmmReg,MachHint)] -> [(CmmExpr,MachHint)] -> SDoc +pprCFunType ress args = + res_type ress <> parens (char '*') <> parens (commafy (map arg_type args)) + where + res_type [] = ptext SLIT("void") + res_type [(one,hint)] = machRepHintCType (cmmRegRep one) hint + + arg_type (expr,hint) = machRepHintCType (cmmExprRep expr) hint + +-- --------------------------------------------------------------------- +-- unconditional branches +pprBranch :: BlockId -> SDoc +pprBranch ident = ptext SLIT("goto") <+> pprBlockId ident <> semi + + +-- --------------------------------------------------------------------- +-- conditional branches to local labels +pprCondBranch :: CmmExpr -> BlockId -> SDoc +pprCondBranch expr ident + = hsep [ ptext SLIT("if") , parens(pprExpr expr) , + ptext SLIT("goto") , (pprBlockId ident) <> semi ] + + +-- --------------------------------------------------------------------- +-- a local table branch +-- +-- we find the fall-through cases +-- +-- N.B. we remove Nothing's from the list of branches, as they are +-- 'undefined'. However, they may be defined one day, so we better +-- document this behaviour. +-- +pprSwitch :: CmmExpr -> [ Maybe BlockId ] -> SDoc +pprSwitch e maybe_ids + = let ids = [ i | Just i <- maybe_ids ] + pairs = zip [ 0 .. ] (concatMap markfalls (group ids)) + in + (hang (ptext SLIT("switch") <+> parens ( pprExpr e ) <+> lbrace) + 4 (vcat ( map caseify pairs ))) + $$ rbrace + + where + -- fall through case + caseify (i,Left ident) = + hsep [ ptext SLIT("case") , pprHexVal i <> colon , + ptext SLIT("/* fall through for"), + pprBlockId ident, + ptext SLIT("*/") ] + + caseify (i,Right ident) = + hsep [ ptext SLIT("case") , pprHexVal i <> colon , + ptext SLIT("goto") , (pprBlockId ident) <> semi ] + + -- mark the bottom of a fallthough sequence of cases as `Right' + markfalls [a] = [Right a] + markfalls as = map (\a -> Left a) (init as) ++ [Right (last as)] + + +-- --------------------------------------------------------------------- +-- Expressions. +-- + +-- C Types: the invariant is that the C expression generated by +-- +-- pprExpr e +-- +-- has a type in C which is also given by +-- +-- machRepCType (cmmExprRep e) +-- +-- (similar invariants apply to the rest of the pretty printer). + +pprExpr :: CmmExpr -> SDoc +pprExpr e = case e of + CmmLit lit -> pprLit lit + + CmmLoad e I64 + -> ptext SLIT("PK_Word64") <> parens (mkP_ <> pprExpr1 e) + + CmmLoad (CmmReg r) rep + | isPtrReg r && rep == wordRep + -> char '*' <> pprAsPtrReg r + + CmmLoad (CmmRegOff r 0) rep + | isPtrReg r && rep == wordRep + -> char '*' <> pprAsPtrReg r + + CmmLoad (CmmRegOff r off) rep + | isPtrReg r && rep == wordRep + -- ToDo: check that the offset is a word multiple? + -> pprAsPtrReg r <> brackets (ppr (off `shiftR` wordShift)) + + CmmLoad expr rep -> + -- the general case: + char '*' <> parens (cCast (machRepPtrCType rep) expr) + + CmmReg reg -> pprCastReg reg + CmmRegOff reg 0 -> pprCastReg reg + + CmmRegOff reg i + | i > 0 -> pprRegOff (char '+') i + | otherwise -> pprRegOff (char '-') (-i) + where + pprRegOff op i' = pprCastReg reg <> op <> int i' + + CmmMachOp mop args -> pprMachOpApp mop args + +pprExpr1 :: CmmExpr -> SDoc +pprExpr1 (CmmLit lit) = pprLit1 lit +pprExpr1 e@(CmmReg _reg) = pprExpr e +pprExpr1 other = parens (pprExpr other) + +-- -------------------------------------------------------------------------- +-- MachOp applications + +pprMachOpApp :: MachOp -> [CmmExpr] -> SDoc + +pprMachOpApp op args + | isMulMayOfloOp op + = ptext SLIT("mulIntMayOflo") <> parens (commafy (map pprExpr args)) <> semi + where isMulMayOfloOp (MO_U_MulMayOflo _) = True + isMulMayOfloOp (MO_S_MulMayOflo _) = True + isMulMayOfloOp _ = False + +pprMachOpApp mop args + = case args of + -- dyadic + [x,y] -> pprArg x <+> pprMachOp_for_C mop <+> pprArg y + + -- unary + [x] -> pprMachOp_for_C mop <> parens (pprArg x) + + _ -> panic "PprC.pprMachOp : machop with wrong number of args" + + where + pprArg e | signedOp mop = cCast (machRepSignedCType (cmmExprRep e)) e + | otherwise = pprExpr1 e + +-- -------------------------------------------------------------------------- +-- Literals + +pprLit :: CmmLit -> SDoc +pprLit lit = case lit of + CmmInt i _rep -> pprHexVal i + CmmFloat f rep -> parens (machRepCType rep) <> (rational f) + CmmLabel clbl -> mkW_ <> pprCLabel clbl + CmmLabelOff clbl i -> mkW_ <> pprCLabel clbl <> char '+' <> int i + +pprLit1 :: CmmLit -> SDoc +pprLit1 lit@(CmmLabelOff _ _) = parens (pprLit lit) +pprLit1 lit@(CmmFloat _ _) = parens (pprLit lit) +pprLit1 other = pprLit other + +-- --------------------------------------------------------------------------- +-- Static data + +pprStatics :: [CmmStatic] -> [SDoc] +pprStatics [] = [] +pprStatics (CmmStaticLit (CmmFloat f F32) : rest) + = pprLit1 (floatToWord f) : pprStatics rest +pprStatics (CmmStaticLit (CmmFloat f F64) : rest) + = map pprLit1 (doubleToWords f) ++ pprStatics rest +pprStatics (CmmStaticLit (CmmInt i I64) : rest) + | machRepByteWidth I32 == wORD_SIZE +#ifdef WORDS_BIGENDIAN + = pprStatics (CmmStaticLit (CmmInt q I32) : + CmmStaticLit (CmmInt r I32) : rest) +#else + = pprStatics (CmmStaticLit (CmmInt r I32) : + CmmStaticLit (CmmInt q I32) : rest) +#endif + where r = i .&. 0xffffffff + q = i `shiftR` 32 +pprStatics (CmmStaticLit lit : rest) + = pprLit1 lit : pprStatics rest +pprStatics (other : rest) + = pprPanic "pprWord" (pprStatic other) + +pprStatic :: CmmStatic -> SDoc +pprStatic s = case s of + + CmmStaticLit lit -> nest 4 (pprLit lit) + CmmAlign i -> nest 4 (ptext SLIT("/* align */") <+> int i) + CmmDataLabel clbl -> pprCLabel clbl <> colon + CmmUninitialised i -> nest 4 (mkC_ <> brackets (int i)) + + -- these should be inlined, like the old .hc + CmmString s' -> nest 4 (mkW_ <> parens(pprStringInCStyle s')) + + +-- --------------------------------------------------------------------------- +-- Block Ids + +pprBlockId :: BlockId -> SDoc +pprBlockId b = char '_' <> ppr (getUnique b) + +-- -------------------------------------------------------------------------- +-- Print a MachOp in a way suitable for emitting via C. +-- + +pprMachOp_for_C :: MachOp -> SDoc + +pprMachOp_for_C mop = case mop of + + -- Integer operations + MO_Add _ -> char '+' + MO_Sub _ -> char '-' + MO_Eq _ -> ptext SLIT("==") + MO_Ne _ -> ptext SLIT("!=") + MO_Mul _ -> char '*' + + MO_S_Quot _ -> char '/' + MO_S_Rem _ -> char '%' + MO_S_Neg _ -> char '-' + + MO_U_Quot _ -> char '/' + MO_U_Rem _ -> char '%' + + -- Signed comparisons (floating-point comparisons also use these) + -- & Unsigned comparisons + MO_S_Ge _ -> ptext SLIT(">=") + MO_S_Le _ -> ptext SLIT("<=") + MO_S_Gt _ -> char '>' + MO_S_Lt _ -> char '<' + + MO_U_Ge _ -> ptext SLIT(">=") + MO_U_Le _ -> ptext SLIT("<=") + MO_U_Gt _ -> char '>' + MO_U_Lt _ -> char '<' + + -- Bitwise operations. Not all of these may be supported at all + -- sizes, and only integral MachReps are valid. + MO_And _ -> char '&' + MO_Or _ -> char '|' + MO_Xor _ -> char '^' + MO_Not _ -> char '~' + MO_Shl _ -> ptext SLIT("<<") + MO_U_Shr _ -> ptext SLIT(">>") -- unsigned shift right + MO_S_Shr _ -> ptext SLIT(">>") -- signed shift right + +-- Conversions. Some of these will be NOPs. +-- Floating-point conversions use the signed variant. +-- We won't know to generate (void*) casts here, but maybe from +-- context elsewhere + +-- noop casts + MO_U_Conv I8 I8 -> empty + MO_U_Conv I16 I16 -> empty + MO_U_Conv I32 I32 -> empty + MO_U_Conv I64 I64 -> empty + MO_U_Conv I128 I128 -> empty + MO_S_Conv I8 I8 -> empty + MO_S_Conv I16 I16 -> empty + MO_S_Conv I32 I32 -> empty + MO_S_Conv I64 I64 -> empty + MO_S_Conv I128 I128 -> empty + + MO_U_Conv _from to -> parens (machRepCType to) + MO_S_Conv _from to -> parens (machRepSignedCType to) + + _ -> panic "PprC.pprMachOp_for_C: unknown machop" + +signedOp :: MachOp -> Bool +signedOp (MO_S_Quot _) = True +signedOp (MO_S_Rem _) = True +signedOp (MO_S_Neg _) = True +signedOp (MO_S_Ge _) = True +signedOp (MO_S_Le _) = True +signedOp (MO_S_Gt _) = True +signedOp (MO_S_Lt _) = True +signedOp (MO_S_Shr _) = True +signedOp (MO_S_Conv _ _) = True +signedOp _ = False + +-- --------------------------------------------------------------------- +-- tend to be implemented by foreign calls + +pprCallishMachOp_for_C :: CallishMachOp -> SDoc + +pprCallishMachOp_for_C mop + = case mop of + MO_F64_Pwr -> ptext SLIT("pow") + MO_F64_Sin -> ptext SLIT("sin") + MO_F64_Cos -> ptext SLIT("cos") + MO_F64_Tan -> ptext SLIT("tan") + MO_F64_Sinh -> ptext SLIT("sinh") + MO_F64_Cosh -> ptext SLIT("cosh") + MO_F64_Tanh -> ptext SLIT("tanh") + MO_F64_Asin -> ptext SLIT("asin") + MO_F64_Acos -> ptext SLIT("asin") + MO_F64_Atan -> ptext SLIT("atan") + MO_F64_Log -> ptext SLIT("log") + MO_F64_Exp -> ptext SLIT("exp") + MO_F64_Sqrt -> ptext SLIT("sqrt") + MO_F32_Pwr -> ptext SLIT("pow") + MO_F32_Sin -> ptext SLIT("sin") + MO_F32_Cos -> ptext SLIT("cos") + MO_F32_Tan -> ptext SLIT("tan") + MO_F32_Sinh -> ptext SLIT("sinh") + MO_F32_Cosh -> ptext SLIT("cosh") + MO_F32_Tanh -> ptext SLIT("tanh") + MO_F32_Asin -> ptext SLIT("asin") + MO_F32_Acos -> ptext SLIT("acos") + MO_F32_Atan -> ptext SLIT("atan") + MO_F32_Log -> ptext SLIT("log") + MO_F32_Exp -> ptext SLIT("exp") + MO_F32_Sqrt -> ptext SLIT("sqrt") + +-- --------------------------------------------------------------------- +-- Useful #defines +-- + +mkJMP_, mkFN_, mkIF_ :: SDoc -> SDoc + +mkJMP_ i = ptext SLIT("JMP_") <> parens i +mkFN_ i = ptext SLIT("FN_") <> parens i -- externally visible function +mkIF_ i = ptext SLIT("IF_") <> parens i -- locally visible + + +mkFB_, mkFE_ :: SDoc +mkFB_ = ptext SLIT("FB_") -- function code begin +mkFE_ = ptext SLIT("FE_") -- function code end + +-- from includes/Stg.h +-- +mkC_,mkW_,mkP_,mkPP_,mkI_,mkA_,mkD_,mkF_,mkB_,mkL_,mkLI_,mkLW_ :: SDoc + +mkC_ = ptext SLIT("(C_)") -- StgChar +mkW_ = ptext SLIT("(W_)") -- StgWord +mkP_ = ptext SLIT("(P_)") -- StgWord* +mkPP_ = ptext SLIT("(PP_)") -- P_* +mkI_ = ptext SLIT("(I_)") -- StgInt +mkA_ = ptext SLIT("(A_)") -- StgAddr +mkD_ = ptext SLIT("(D_)") -- const StgWord* +mkF_ = ptext SLIT("(F_)") -- StgFunPtr +mkB_ = ptext SLIT("(B_)") -- StgByteArray +mkL_ = ptext SLIT("(L_)") -- StgClosurePtr + +mkLI_ = ptext SLIT("(LI_)") -- StgInt64 +mkLW_ = ptext SLIT("(LW_)") -- StgWord64 + + +-- --------------------------------------------------------------------- +-- +-- Assignments +-- +-- Generating assignments is what we're all about, here +-- +pprAssign :: CmmReg -> CmmExpr -> SDoc + +-- dest is a reg, rhs is a reg +pprAssign r1 (CmmReg r2) + | not (isStrangeTypeReg r1) && not (isStrangeTypeReg r2) + || isPtrReg r1 && isPtrReg r2 + = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, semi ] + +-- dest is a reg, rhs is a CmmRegOff +pprAssign r1 (CmmRegOff r2 off) + | not (isStrangeTypeReg r1) && not (isStrangeTypeReg r2) + || isPtrReg r1 && isPtrReg r2 + = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, op, int off', semi ] + where + off1 | isPtrReg r2 = off `shiftR` wordShift + | otherwise = off + + (op,off') | off >= 0 = (char '+', off1) + | otherwise = (char '-', -off1) + +-- dest is a reg, rhs is anything +pprAssign r1 r2 + = pprCastReg r1 <+> equals <+> pprExpr r2 <> semi + +-- --------------------------------------------------------------------- +-- Registers + +pprCastReg reg + | isStrangeTypeReg reg = mkW_ <> pprReg reg + | otherwise = pprReg reg + +-- True if the register has type StgPtr in C, otherwise it has an +-- integer type. We need to take care with pointer arithmetic on registers +-- with type StgPtr. +isPtrReg :: CmmReg -> Bool +isPtrReg (CmmLocal _) = False +isPtrReg (CmmGlobal r) = isPtrGlobalReg r + +isPtrGlobalReg :: GlobalReg -> Bool +isPtrGlobalReg (VanillaReg n) = True +isPtrGlobalReg Sp = True +isPtrGlobalReg Hp = True +isPtrGlobalReg HpLim = True +isPtrGlobalReg SpLim = True +isPtrGlobalReg _ = False + +-- True if in C this register doesn't have the type given by +-- (machRepCType (cmmRegRep reg)), so it has to be cast. +isStrangeTypeReg :: CmmReg -> Bool +isStrangeTypeReg (CmmLocal _) = False +isStrangeTypeReg (CmmGlobal g) = isStrangeTypeGlobal g + +isStrangeTypeGlobal :: GlobalReg -> Bool +isStrangeTypeGlobal CurrentTSO = True +isStrangeTypeGlobal CurrentNursery = True +isStrangeTypeGlobal r = isPtrGlobalReg r + + +-- pprReg just prints the register name. +-- +pprReg :: CmmReg -> SDoc +pprReg r = case r of + CmmLocal local -> pprLocalReg local + CmmGlobal global -> pprGlobalReg global + +pprAsPtrReg :: CmmReg -> SDoc +pprAsPtrReg (CmmGlobal (VanillaReg n)) = char 'R' <> int n <> ptext SLIT(".p") +pprAsPtrReg other_reg = pprReg other_reg + +pprGlobalReg :: GlobalReg -> SDoc +pprGlobalReg gr = case gr of + VanillaReg n -> char 'R' <> int n <> ptext SLIT(".w") + FloatReg n -> char 'F' <> int n + DoubleReg n -> char 'D' <> int n + LongReg n -> char 'L' <> int n + Sp -> ptext SLIT("Sp") + SpLim -> ptext SLIT("SpLim") + Hp -> ptext SLIT("Hp") + HpLim -> ptext SLIT("HpLim") + CurrentTSO -> ptext SLIT("CurrentTSO") + CurrentNursery -> ptext SLIT("CurrentNursery") + HpAlloc -> ptext SLIT("HpAlloc") + BaseReg -> ptext SLIT("BaseReg") + GCEnter1 -> ptext SLIT("stg_gc_enter_1") + GCFun -> ptext SLIT("stg_gc_fun") + +pprLocalReg :: LocalReg -> SDoc +pprLocalReg (LocalReg uniq _rep) = char '_' <> ppr uniq + +-- ----------------------------------------------------------------------------- +-- Foreign Calls + +pprCall :: SDoc -> CCallConv -> [(CmmReg,MachHint)] -> [(CmmExpr,MachHint)] + -> Maybe [GlobalReg] -> SDoc + +pprCall ppr_fn cconv results args vols + | not (is_cish cconv) + = panic "pprForeignCall: unknown calling convention" + + | otherwise + = save vols $$ + ptext SLIT("CALLER_SAVE_SYSTEM") $$ + hcat [ ppr_results results, ppr_fn, + parens (commafy (map pprArg args)), semi ] $$ + ptext SLIT("CALLER_RESTORE_SYSTEM") $$ + restore vols + where + ppr_results [] = empty + ppr_results [(one,hint)] = pprArg (CmmReg one,hint) <> ptext SLIT(" = ") + ppr_results _other = panic "pprCall: multiple results" + + pprArg (expr, PtrHint) + = cCast (ptext SLIT("void *")) expr + -- see comment by machRepHintCType below + pprArg (expr, SignedHint) + = cCast (machRepSignedCType (cmmExprRep expr)) expr + pprArg (expr, _other) + = pprExpr expr + + save = save_restore SLIT("CALLER_SAVE") + restore = save_restore SLIT("CALLER_RESTORE") + + -- Nothing says "I don't know what's live; save everything" + -- CALLER_SAVE_USER is defined in ghc/includes/Regs.h + save_restore txt Nothing = ptext txt <> ptext SLIT("_USER") + save_restore txt (Just these) = vcat (map saveRestoreGlobal these) + where saveRestoreGlobal r = ptext txt <> char '_' <> pprGlobalRegName r + +pprGlobalRegName :: GlobalReg -> SDoc +pprGlobalRegName gr = case gr of + VanillaReg n -> char 'R' <> int n -- without the .w suffix + _ -> pprGlobalReg gr + +is_cish CCallConv = True +is_cish StdCallConv = True +is_cish _ = False + +-- --------------------------------------------------------------------- +-- Find and print local and external declarations for a list of +-- Cmm statements. +-- +pprTempAndExternDecls :: [CmmBasicBlock] -> (SDoc{-temps-}, SDoc{-externs-}) +pprTempAndExternDecls stmts + = (vcat (map pprTempDecl (eltsUFM temps)), + vcat (map (pprExternDecl False{-ToDo-}) (keysFM lbls))) + where (temps, lbls) = runTE (mapM_ te_BB stmts) + +pprDataExterns :: [CmmStatic] -> SDoc +pprDataExterns statics + = vcat (map (pprExternDecl False{-ToDo-}) (keysFM lbls)) + where (_, lbls) = runTE (mapM_ te_Static statics) + +pprTempDecl :: LocalReg -> SDoc +pprTempDecl l@(LocalReg _uniq rep) + = hcat [ machRepCType rep, space, pprLocalReg l, semi ] + +pprExternDecl :: Bool -> CLabel -> SDoc +pprExternDecl in_srt lbl + -- do not print anything for "known external" things + | not (needsCDecl lbl) = empty + | otherwise = + hcat [ visibility, label_type (labelType lbl), + lparen, dyn_wrapper (pprCLabel lbl), text ");" ] + where + dyn_wrapper d + | in_srt && labelDynamic lbl = text "DLL_IMPORT_DATA_VAR" <> parens d + | otherwise = d + + label_type CodeLabel = ptext SLIT("F_") + label_type DataLabel = ptext SLIT("I_") + + visibility + | externallyVisibleCLabel lbl = char 'E' + | otherwise = char 'I' + + +type TEState = (UniqSet LocalReg, FiniteMap CLabel ()) +newtype TE a = TE { unTE :: TEState -> (a, TEState) } + +instance Monad TE where + TE m >>= k = TE $ \s -> case m s of (a, s') -> unTE (k a) s' + return a = TE $ \s -> (a, s) + +te_lbl :: CLabel -> TE () +te_lbl lbl = TE $ \(temps,lbls) -> ((), (temps, addToFM lbls lbl ())) + +te_temp :: LocalReg -> TE () +te_temp r = TE $ \(temps,lbls) -> ((), (addOneToUniqSet temps r, lbls)) + +runTE :: TE () -> TEState +runTE (TE m) = snd (m (emptyUniqSet, emptyFM)) + +te_Static :: CmmStatic -> TE () +te_Static (CmmStaticLit lit) = te_Lit lit +te_Static _ = return () + +te_BB :: CmmBasicBlock -> TE () +te_BB (BasicBlock _ ss) = mapM_ te_Stmt ss + +te_Lit :: CmmLit -> TE () +te_Lit (CmmLabel l) = te_lbl l +te_Lit _ = return () + +te_Stmt :: CmmStmt -> TE () +te_Stmt (CmmAssign r e) = te_Reg r >> te_Expr e +te_Stmt (CmmStore l r) = te_Expr l >> te_Expr r +te_Stmt (CmmCall _ rs es _) = mapM_ (te_Reg.fst) rs >> + mapM_ (te_Expr.fst) es +te_Stmt (CmmCondBranch e _) = te_Expr e +te_Stmt (CmmSwitch e _) = te_Expr e +te_Stmt (CmmJump e _) = te_Expr e +te_Stmt _ = return () + +te_Expr :: CmmExpr -> TE () +te_Expr (CmmLit lit) = te_Lit lit +te_Expr (CmmReg r) = te_Reg r +te_Expr (CmmLoad e _) = te_Expr e +te_Expr (CmmMachOp _ es) = mapM_ te_Expr es +te_Expr (CmmRegOff r _) = te_Reg r +te_Expr _ = return () + +te_Reg :: CmmReg -> TE () +te_Reg (CmmLocal l) = te_temp l +te_Reg _ = return () + + +-- --------------------------------------------------------------------- +-- C types for MachReps + +cCast :: SDoc -> CmmExpr -> SDoc +cCast ty expr = parens ty <> pprExpr1 expr + +-- This is for finding the types of foreign call arguments. For a pointer +-- argument, we always cast the argument to (void *), to avoid warnings from +-- the C compiler. +machRepHintCType :: MachRep -> MachHint -> SDoc +machRepHintCType rep PtrHint = ptext SLIT("void *") +machRepHintCType rep SignedHint = machRepSignedCType rep +machRepHintCType rep _other = machRepCType rep + +machRepPtrCType :: MachRep -> SDoc +machRepPtrCType r | r == wordRep = ptext SLIT("P_") + | otherwise = machRepCType r <> char '*' + +machRepCType :: MachRep -> SDoc +machRepCType r | r == wordRep = ptext SLIT("W_") + | otherwise = sized_type + where sized_type = case r of + I8 -> ptext SLIT("StgWord8") + I16 -> ptext SLIT("StgWord16") + I32 -> ptext SLIT("StgWord32") + I64 -> ptext SLIT("StgWord64") + F32 -> ptext SLIT("StgFloat") -- ToDo: correct? + F64 -> ptext SLIT("StgDouble") + _ -> panic "machRepCType" + +machRepSignedCType :: MachRep -> SDoc +machRepSignedCType r | r == wordRep = ptext SLIT("I_") + | otherwise = sized_type + where sized_type = case r of + I8 -> ptext SLIT("StgInt8") + I16 -> ptext SLIT("StgInt16") + I32 -> ptext SLIT("StgInt32") + I64 -> ptext SLIT("StgInt64") + F32 -> ptext SLIT("StgFloat") -- ToDo: correct? + F64 -> ptext SLIT("StgDouble") + _ -> panic "machRepCType" + +-- --------------------------------------------------------------------- +-- print strings as valid C strings + +-- Assumes it contains only characters '\0'..'\xFF'! +pprFSInCStyle :: FastString -> SDoc +pprFSInCStyle fs = pprStringInCStyle (unpackFS fs) + +pprStringInCStyle :: String -> SDoc +pprStringInCStyle s = doubleQuotes (text (concatMap charToC s)) + +charToC :: Char -> String +charToC '\"' = "\\\"" +charToC '\'' = "\\\'" +charToC '\\' = "\\\\" +charToC c | c >= ' ' && c <= '~' = [c] + | c > '\xFF' = panic ("charToC "++show c) + | otherwise = ['\\', + chr (ord '0' + ord c `div` 64), + chr (ord '0' + ord c `div` 8 `mod` 8), + chr (ord '0' + ord c `mod` 8)] + + +-- --------------------------------------------------------------------------- +-- Initialising static objects with floating-point numbers. We can't +-- just emit the floating point number, because C will cast it to an int +-- by rounding it. We want the actual bit-representation of the float. + +-- This is a hack to turn the floating point numbers into ints that we +-- can safely initialise to static locations. + +big_doubles + | machRepByteWidth F64 == 2 * wORD_SIZE = True + | machRepByteWidth F64 == wORD_SIZE = False + | otherwise = panic "big_doubles" + +#if __GLASGOW_HASKELL__ >= 504 +newFloatArray :: (Int,Int) -> ST s (STUArray s Int Float) +newFloatArray = newArray_ + +newDoubleArray :: (Int,Int) -> ST s (STUArray s Int Double) +newDoubleArray = newArray_ + +castFloatToIntArray :: STUArray s Int Float -> ST s (STUArray s Int Int) +castFloatToIntArray = castSTUArray + +castDoubleToIntArray :: STUArray s Int Double -> ST s (STUArray s Int Int) +castDoubleToIntArray = castSTUArray + +writeFloatArray :: STUArray s Int Float -> Int -> Float -> ST s () +writeFloatArray = writeArray + +writeDoubleArray :: STUArray s Int Double -> Int -> Double -> ST s () +writeDoubleArray = writeArray + +readIntArray :: STUArray s Int Int -> Int -> ST s Int +readIntArray = readArray + +#else + +castFloatToIntArray :: MutableByteArray s t -> ST s (MutableByteArray s t) +castFloatToIntArray = return + +castDoubleToIntArray :: MutableByteArray s t -> ST s (MutableByteArray s t) +castDoubleToIntArray = return + +#endif + +-- floats are always 1 word +floatToWord :: Rational -> CmmLit +floatToWord r + = runST (do + arr <- newFloatArray ((0::Int),0) + writeFloatArray arr 0 (fromRational r) + arr' <- castFloatToIntArray arr + i <- readIntArray arr' 0 + return (CmmInt (toInteger i) wordRep) + ) + +doubleToWords :: Rational -> [CmmLit] +doubleToWords r + | big_doubles -- doubles are 2 words + = runST (do + arr <- newDoubleArray ((0::Int),1) + writeDoubleArray arr 0 (fromRational r) + arr' <- castDoubleToIntArray arr + i1 <- readIntArray arr' 0 + i2 <- readIntArray arr' 1 + return [ CmmInt (toInteger i1) wordRep + , CmmInt (toInteger i2) wordRep + ] + ) + | otherwise -- doubles are 1 word + = runST (do + arr <- newDoubleArray ((0::Int),0) + writeDoubleArray arr 0 (fromRational r) + arr' <- castDoubleToIntArray arr + i <- readIntArray arr' 0 + return [ CmmInt (toInteger i) wordRep ] + ) + +-- --------------------------------------------------------------------------- +-- Utils + +wordShift :: Int +wordShift = machRepLogWidth wordRep + +commafy :: [SDoc] -> SDoc +commafy xs = hsep $ punctuate comma xs + +-- Print in C hex format: 0x13fa +pprHexVal :: Integer -> SDoc +pprHexVal 0 = ptext SLIT("0x0") +pprHexVal w + | w < 0 = parens (char '-' <> ptext SLIT("0x") <> go (-w)) + | otherwise = ptext SLIT("0x") <> go w + where + go 0 = empty + go w' = go q <> dig + where + (q,r) = w' `quotRem` 16 + dig | r < 10 = char (chr (fromInteger r + ord '0')) + | otherwise = char (chr (fromInteger r - 10 + ord 'a')) + diff --git a/ghc/compiler/cmm/PprCmm.hs b/ghc/compiler/cmm/PprCmm.hs new file mode 100644 index 0000000000..fb1dec1c7c --- /dev/null +++ b/ghc/compiler/cmm/PprCmm.hs @@ -0,0 +1,460 @@ +---------------------------------------------------------------------------- +-- +-- Pretty-printing of Cmm as (a superset of) C-- +-- +-- (c) The University of Glasgow 2004 +-- +----------------------------------------------------------------------------- + +-- +-- This is where we walk over Cmm emitting an external representation, +-- suitable for parsing, in a syntax strongly reminiscent of C--. This +-- is the "External Core" for the Cmm layer. +-- +-- As such, this should be a well-defined syntax: we want it to look nice. +-- Thus, we try wherever possible to use syntax defined in [1], +-- "The C-- Reference Manual", http://www.cminusminus.org/. We differ +-- slightly, in some cases. For one, we use I8 .. I64 for types, rather +-- than C--'s bits8 .. bits64. +-- +-- We try to ensure that all information available in the abstract +-- syntax is reproduced, or reproducible, in the concrete syntax. +-- Data that is not in printed out can be reconstructed according to +-- conventions used in the pretty printer. There are at least two such +-- cases: +-- 1) if a value has wordRep type, the type is not appended in the +-- output. +-- 2) MachOps that operate over wordRep type are printed in a +-- C-style, rather than as their internal MachRep name. +-- +-- These conventions produce much more readable Cmm output. +-- +-- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs +-- + +module PprCmm ( + writeCmms, pprCmms, pprCmm, pprStmt, pprExpr + ) where + +#include "HsVersions.h" + +import Cmm +import CmmUtils ( isTrivialCmmExpr ) +import MachOp ( MachOp(..), pprMachOp, MachRep(..), wordRep ) +import CLabel ( pprCLabel, mkForeignLabel, entryLblToInfoLbl ) + +import ForeignCall ( CCallConv(..) ) +import Unique ( getUnique ) +import Outputable +import FastString ( mkFastString ) + +import Data.List ( intersperse, groupBy ) +import IO ( Handle ) +import Maybe ( isJust ) + +pprCmms :: [Cmm] -> SDoc +pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms)) + where + separator = space $$ ptext SLIT("-------------------") $$ space + +writeCmms :: Handle -> [Cmm] -> IO () +writeCmms handle cmms = printForC handle (pprCmms cmms) + +----------------------------------------------------------------------------- + +instance Outputable Cmm where + ppr c = pprCmm c + +instance Outputable CmmTop where + ppr t = pprTop t + +instance Outputable CmmBasicBlock where + ppr b = pprBBlock b + +instance Outputable CmmStmt where + ppr s = pprStmt s + +instance Outputable CmmExpr where + ppr e = pprExpr e + +instance Outputable CmmReg where + ppr e = pprReg e + +instance Outputable GlobalReg where + ppr e = pprGlobalReg e + +----------------------------------------------------------------------------- + +pprCmm :: Cmm -> SDoc +pprCmm (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops + +-- -------------------------------------------------------------------------- +-- Top level `procedure' blocks. The info tables, if not null, are +-- printed in the style of C--'s 'stackdata' declaration, just inside +-- the proc body, and are labelled with the procedure name ++ "_info". +-- +pprTop :: CmmTop -> SDoc +pprTop (CmmProc info lbl params blocks ) + + = vcat [ pprCLabel lbl <> parens (commafy $ map pprLocalReg params) <+> lbrace + , nest 8 $ pprInfo info lbl + , nest 4 $ vcat (map ppr blocks) + , rbrace ] + + where + pprInfo [] _ = empty + pprInfo i label = + (hang (pprCLabel (entryLblToInfoLbl label) <+> lbrace ) + 4 $ vcat (map pprStatic i)) + $$ rbrace + +-- -------------------------------------------------------------------------- +-- We follow [1], 4.5 +-- +-- section "data" { ... } +-- +pprTop (CmmData section ds) = + (hang (pprSection section <+> lbrace) 4 (vcat (map pprStatic ds))) + $$ rbrace + + +-- -------------------------------------------------------------------------- +-- Basic blocks look like assembly blocks. +-- lbl: stmt ; stmt ; .. +pprBBlock :: CmmBasicBlock -> SDoc +pprBBlock (BasicBlock ident stmts) = + hang (pprBlockId ident <> colon) 4 (vcat (map ppr stmts)) + +-- -------------------------------------------------------------------------- +-- Statements. C-- usually, exceptions to this should be obvious. +-- +pprStmt :: CmmStmt -> SDoc +pprStmt stmt = case stmt of + + -- ; + CmmNop -> semi + + -- // text + CmmComment s -> text "//" <+> ftext s + + -- reg = expr; + CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi + + -- rep[lv] = expr; + CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi + where + rep = ppr ( cmmExprRep expr ) + + -- call "ccall" foo(x, y)[r1, r2]; + -- ToDo ppr volatile + CmmCall (CmmForeignCall fn cconv) results args _volatile -> + hcat [ ptext SLIT("call"), space, + doubleQuotes(ppr cconv), space, + target fn, parens ( commafy $ map ppr args ), + (if null results + then empty + else brackets( commafy $ map ppr results)), semi ] + where + target (CmmLit lit) = pprLit lit + target fn' = parens (ppr fn') + + CmmCall (CmmPrim op) results args volatile -> + pprStmt (CmmCall (CmmForeignCall (CmmLit lbl) CCallConv) + results args volatile) + where + lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False) + + CmmBranch ident -> genBranch ident + CmmCondBranch expr ident -> genCondBranch expr ident + CmmJump expr params -> genJump expr params + CmmSwitch arg ids -> genSwitch arg ids + +-- -------------------------------------------------------------------------- +-- goto local label. [1], section 6.6 +-- +-- goto lbl; +-- +genBranch :: BlockId -> SDoc +genBranch ident = + ptext SLIT("goto") <+> pprBlockId ident <> semi + +-- -------------------------------------------------------------------------- +-- Conditional. [1], section 6.4 +-- +-- if (expr) { goto lbl; } +-- +genCondBranch :: CmmExpr -> BlockId -> SDoc +genCondBranch expr ident = + hsep [ ptext SLIT("if") + , parens(ppr expr) + , ptext SLIT("goto") + , pprBlockId ident <> semi ] + +-- -------------------------------------------------------------------------- +-- A tail call. [1], Section 6.9 +-- +-- jump foo(a, b, c); +-- +genJump :: CmmExpr -> [LocalReg] -> SDoc +genJump expr actuals = + + hcat [ ptext SLIT("jump") + , space + , if isTrivialCmmExpr expr + then pprExpr expr + else case expr of + CmmLoad (CmmReg _) _ -> pprExpr expr + _ -> parens (pprExpr expr) + , pprActuals actuals + , semi ] + + where + pprActuals [] = empty + pprActuals as = parens ( commafy $ map pprLocalReg as ) + +-- -------------------------------------------------------------------------- +-- Tabled jump to local label +-- +-- The syntax is from [1], section 6.5 +-- +-- switch [0 .. n] (expr) { case ... ; } +-- +-- N.B. we remove 'Nothing's from the list of branches, as they don't +-- seem to make sense currently. This may change, if they are defined in +-- some way. +-- +genSwitch :: CmmExpr -> [Maybe BlockId] -> SDoc +genSwitch expr maybe_ids + + = let ids = [ i | Just i <- maybe_ids ] + pairs = groupBy snds (zip [0 .. ] ids ) + + in hang (hcat [ ptext SLIT("switch [0 .. ") + , int (length ids - 1) + , ptext SLIT("] ") + , if isTrivialCmmExpr expr + then pprExpr expr + else parens (pprExpr expr) + , ptext SLIT(" {") + ]) + 4 (vcat ( map caseify pairs )) $$ rbrace + + where + snds a b = (snd a) == (snd b) + + caseify :: [(Int,BlockId)] -> SDoc + caseify as + = let (is,ids) = unzip as + in hsep [ ptext SLIT("case") + , hcat (punctuate comma (map int is)) + , ptext SLIT(": goto") + , pprBlockId (head ids) <> semi ] + +-- -------------------------------------------------------------------------- +-- Expressions +-- + +pprExpr :: CmmExpr -> SDoc +pprExpr e + = case e of + CmmRegOff reg i -> + pprExpr (CmmMachOp (MO_Add rep) + [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)]) + where rep = cmmRegRep reg + CmmLit lit -> pprLit lit + _other -> pprExpr1 e + +-- Here's the precedence table from CmmParse.y: +-- %nonassoc '>=' '>' '<=' '<' '!=' '==' +-- %left '|' +-- %left '^' +-- %left '&' +-- %left '>>' '<<' +-- %left '-' '+' +-- %left '/' '*' '%' +-- %right '~' + +-- We just cope with the common operators for now, the rest will get +-- a default conservative behaviour. + +-- %nonassoc '>=' '>' '<=' '<' '!=' '==' +pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op + = pprExpr7 x <+> doc <+> pprExpr7 y +pprExpr1 e = pprExpr7 e + +infixMachOp1 (MO_Eq _) = Just (ptext SLIT("==")) +infixMachOp1 (MO_Ne _) = Just (ptext SLIT("!=")) +infixMachOp1 (MO_Shl _) = Just (ptext SLIT("<<")) +infixMachOp1 (MO_U_Shr _) = Just (ptext SLIT(">>")) +infixMachOp1 (MO_U_Ge _) = Just (ptext SLIT(">=")) +infixMachOp1 (MO_U_Le _) = Just (ptext SLIT("<=")) +infixMachOp1 (MO_U_Gt _) = Just (char '>') +infixMachOp1 (MO_U_Lt _) = Just (char '<') +infixMachOp1 _ = Nothing + +-- %left '-' '+' +pprExpr7 (CmmMachOp op [x,y]) | Just doc <- infixMachOp7 op + = pprExpr7 x <+> doc <+> pprExpr8 y +pprExpr7 e = pprExpr8 e + +infixMachOp7 (MO_Add _) = Just (char '+') +infixMachOp7 (MO_Sub _) = Just (char '-') +infixMachOp7 _ = Nothing + +-- %left '/' '*' '%' +pprExpr8 (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op + = pprExpr8 x <+> doc <+> pprExpr9 y +pprExpr8 e = pprExpr9 e + +infixMachOp8 (MO_U_Quot _) = Just (char '/') +infixMachOp8 (MO_Mul _) = Just (char '*') +infixMachOp8 (MO_U_Rem _) = Just (char '%') +infixMachOp8 _ = Nothing + +pprExpr9 :: CmmExpr -> SDoc +pprExpr9 e = + case e of + CmmLit lit -> pprLit1 lit + CmmLoad expr rep -> ppr rep <> brackets( ppr expr ) + CmmReg reg -> ppr reg + CmmMachOp mop args -> genMachOp mop args + e -> parens (pprExpr e) + +genMachOp :: MachOp -> [CmmExpr] -> SDoc +genMachOp mop args + | Just doc <- infixMachOp mop = case args of + -- dyadic + [x,y] -> pprExpr9 x <+> doc <+> pprExpr9 y + + -- unary + [x] -> doc <> pprExpr9 x + + _ -> pprTrace "PprCmm.genMachOp: machop with strange number of args" + (pprMachOp mop <+> + parens (hcat $ punctuate comma (map pprExpr args))) + empty + + | isJust (infixMachOp1 mop) + || isJust (infixMachOp7 mop) + || isJust (infixMachOp8 mop) = parens (pprExpr (CmmMachOp mop args)) + + | otherwise = char '%' <> pprMachOp mop <> parens (commafy (map pprExpr args)) + +-- +-- Unsigned ops on the word size of the machine get nice symbols. +-- All else get dumped in their ugly format. +-- +infixMachOp :: MachOp -> Maybe SDoc +infixMachOp mop + = case mop of + MO_And _ -> Just $ char '&' + MO_Or _ -> Just $ char '|' + MO_Xor _ -> Just $ char '^' + MO_Not _ -> Just $ char '~' + MO_S_Neg _ -> Just $ char '-' -- there is no unsigned neg :) + MO_Not _ -> Just $ char '~' + _ -> Nothing + +-- -------------------------------------------------------------------------- +-- Literals. +-- To minimise line noise we adopt the convention that if the literal +-- has the natural machine word size, we do not append the type +-- +pprLit :: CmmLit -> SDoc +pprLit lit = case lit of + CmmInt i rep -> + hcat [ (if i < 0 then parens else id)(integer i) + , (if rep == wordRep + then empty + else space <> dcolon <+> ppr rep) ] + + CmmFloat f rep -> hsep [ rational f, dcolon, ppr rep ] + CmmLabel clbl -> pprCLabel clbl + CmmLabelOff clbl i -> pprCLabel clbl <> ppr_offset i + +pprLit1 lit@(CmmLabelOff clbl i) = parens (pprLit lit) +pprLit1 lit = pprLit lit + +ppr_offset :: Int -> SDoc +ppr_offset i + | i==0 = empty + | i>=0 = char '+' <> int i + | otherwise = char '-' <> int (-i) + +-- -------------------------------------------------------------------------- +-- Static data. +-- Strings are printed as C strings, and we print them as I8[], +-- following C-- +-- +pprStatic :: CmmStatic -> SDoc +pprStatic s = case s of + CmmStaticLit lit -> nest 4 $ ptext SLIT("const") <+> pprLit lit <> semi + CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i) + CmmAlign i -> nest 4 $ text "align" <+> int i + CmmDataLabel clbl -> pprCLabel clbl <> colon + CmmString s' -> nest 4 $ text "I8[]" <+> doubleQuotes (text s') + +-- -------------------------------------------------------------------------- +-- Registers, whether local (temps) or global +-- +pprReg :: CmmReg -> SDoc +pprReg r + = case r of + CmmLocal local -> pprLocalReg local + CmmGlobal global -> pprGlobalReg global + +-- +-- We only print the type of the local reg if it isn't wordRep +-- +pprLocalReg :: LocalReg -> SDoc +pprLocalReg (LocalReg uniq rep) + = hcat [ char '_', ppr uniq, + (if rep == wordRep + then empty else dcolon <> ppr rep) ] + +-- needs to be kept in syn with Cmm.hs.GlobalReg +-- +pprGlobalReg :: GlobalReg -> SDoc +pprGlobalReg gr + = case gr of + VanillaReg n -> char 'R' <> int n + FloatReg n -> char 'F' <> int n + DoubleReg n -> char 'D' <> int n + LongReg n -> char 'L' <> int n + Sp -> ptext SLIT("Sp") + SpLim -> ptext SLIT("SpLim") + Hp -> ptext SLIT("Hp") + HpLim -> ptext SLIT("HpLim") + CurrentTSO -> ptext SLIT("CurrentTSO") + CurrentNursery -> ptext SLIT("CurrentNursery") + HpAlloc -> ptext SLIT("HpAlloc") + GCEnter1 -> ptext SLIT("stg_gc_enter_1") + GCFun -> ptext SLIT("stg_gc_fun") + BaseReg -> ptext SLIT("BaseReg") + + _ -> panic $ "PprCmm.pprGlobalReg: unknown global reg" + +-- -------------------------------------------------------------------------- +-- data sections +-- +pprSection :: Section -> SDoc +pprSection s = case s of + Text -> section <+> doubleQuotes (ptext SLIT("text")) + Data -> section <+> doubleQuotes (ptext SLIT("data")) + ReadOnlyData -> section <+> doubleQuotes (ptext SLIT("readonly")) + UninitialisedData -> section <+> doubleQuotes (ptext SLIT("uninitialised")) + OtherSection s' -> section <+> doubleQuotes (text s') + where + section = ptext SLIT("section") + +-- -------------------------------------------------------------------------- +-- Basic block ids +-- +pprBlockId :: BlockId -> SDoc +pprBlockId b = ppr $ getUnique b + +----------------------------------------------------------------------------- + +commafy :: [SDoc] -> SDoc +commafy xs = hsep $ punctuate comma xs + diff --git a/ghc/compiler/codeGen/CgBindery.lhs b/ghc/compiler/codeGen/CgBindery.lhs index b195b5c864..0f858777c2 100644 --- a/ghc/compiler/codeGen/CgBindery.lhs +++ b/ghc/compiler/codeGen/CgBindery.lhs @@ -8,49 +8,49 @@ module CgBindery ( CgBindings, CgIdInfo, StableLoc, VolatileLoc, - stableAmodeIdInfo, heapIdInfo, + cgIdInfoId, cgIdInfoArgRep, cgIdInfoLF, + + stableIdInfo, heapIdInfo, letNoEscapeIdInfo, idInfoToAmode, addBindC, addBindsC, nukeVolatileBinds, nukeDeadBindings, + getLiveStackSlots, - bindNewToStack, rebindToStack, + bindArgsToStack, rebindToStack, bindNewToNode, bindNewToReg, bindArgsToRegs, bindNewToTemp, - getArgAmode, getArgAmodes, - getCAddrModeAndInfo, getCAddrMode, + getArgAmode, getArgAmodes, + getCgIdInfo, getCAddrModeIfVolatile, getVolatileRegs, - - buildContLivenessMask + maybeLetNoEscape, ) where #include "HsVersions.h" -import AbsCSyn import CgMonad - -import CgUsages ( getHpRelOffset, getSpRelOffset, getRealSp ) -import CgStackery ( freeStackSlots, getStackFrame ) -import CLabel ( mkClosureLabel, - mkBitmapLabel, pprCLabel ) +import CgHeapery ( getHpRelOffset ) +import CgStackery ( freeStackSlots, getSpRelOffset ) +import CgUtils ( cgLit, cmmOffsetW ) +import CLabel ( mkClosureLabel, pprCLabel ) import ClosureInfo ( mkLFImported, mkLFArgument, LambdaFormInfo ) -import Bitmap -import PrimRep ( isFollowableRep, getPrimRepSize ) -import Id ( Id, idPrimRep, idType ) -import Type ( typePrimRep ) + +import Cmm +import PprCmm ( {- instance Outputable -} ) +import SMRep ( CgRep(..), WordOff, isFollowableArg, + isVoidArg, cgRepSizeW, argMachRep, + idCgRep, typeCgRep ) +import Id ( Id, idName ) import VarEnv import VarSet ( varSetElems ) -import Literal ( Literal ) -import Maybes ( catMaybes, maybeToBool, seqMaybe ) -import Name ( isInternalName, NamedThing(..) ) -import PprAbsC ( pprAmode, pprMagicId ) -import PrimRep ( PrimRep(..) ) +import Literal ( literalType ) +import Maybes ( catMaybes ) +import Name ( isExternalName ) import StgSyn ( StgArg, StgLiveVars, GenStgArg(..), isStgTypeArg ) -import Unique ( Unique, Uniquable(..) ) +import Unique ( Uniquable(..) ) import UniqSet ( elementOfUniqSet ) -import Util ( zipWithEqual, sortLt ) import Outputable \end{code} @@ -73,22 +73,30 @@ environment. So there can be two bindings for a given name. type CgBindings = IdEnv CgIdInfo data CgIdInfo - = MkCgIdInfo Id -- Id that this is the info for - VolatileLoc - StableLoc - LambdaFormInfo + = CgIdInfo + { cg_id :: Id -- Id that this is the info for + -- Can differ from the Id at occurrence sites by + -- virtue of being externalised, for splittable C + , cg_rep :: CgRep + , cg_vol :: VolatileLoc + , cg_stb :: StableLoc + , cg_lf :: LambdaFormInfo } + +mkCgIdInfo id vol stb lf + = CgIdInfo { cg_id = id, cg_vol = vol, cg_stb = stb, + cg_lf = lf, cg_rep = idCgRep id } + +voidIdInfo id = CgIdInfo { cg_id = id, cg_vol = NoVolatileLoc + , cg_stb = VoidLoc, cg_lf = mkLFArgument id + , cg_rep = VoidArg } + -- Used just for VoidRep things data VolatileLoc = NoVolatileLoc - | TempVarLoc Unique - - | RegLoc MagicId -- in one of the magic registers - -- (probably {Int,Float,Char,etc}Reg) - - | VirHpLoc VirtualHeapOffset -- Hp+offset (address of closure) - - | VirNodeLoc VirtualHeapOffset -- Cts of offset indirect from Node - -- ie *(Node+offset) + | RegLoc CmmReg -- In one of the registers (global or local) + | VirHpLoc VirtualHpOffset -- Hp+offset (address of closure) + | VirNodeLoc VirtualHpOffset -- Cts of offset indirect from Node + -- ie *(Node+offset) \end{code} @StableLoc@ encodes where an Id can be found, used by @@ -97,33 +105,37 @@ the @CgBindings@ environment in @CgBindery@. \begin{code} data StableLoc = NoStableLoc - | VirStkLoc VirtualSpOffset - | LitLoc Literal - | StableAmodeLoc CAddrMode --- these are so StableLoc can be abstract: + | VirStkLoc VirtualSpOffset -- The thing is held in this + -- stack slot -maybeStkLoc (VirStkLoc offset) = Just offset -maybeStkLoc _ = Nothing + | VirStkLNE VirtualSpOffset -- A let-no-escape thing; the + -- value is this stack pointer + -- (as opposed to the contents of the slot) + + | StableLoc CmmExpr + | VoidLoc -- Used only for VoidRep variables. They never need to + -- be saved, so it makes sense to treat treat them as + -- having a stable location \end{code} \begin{code} instance Outputable CgIdInfo where - ppr (MkCgIdInfo id vol stb lf) + ppr (CgIdInfo id rep vol stb lf) = ppr id <+> ptext SLIT("-->") <+> vcat [ppr vol, ppr stb] instance Outputable VolatileLoc where ppr NoVolatileLoc = empty - ppr (TempVarLoc u) = ptext SLIT("tmp") <+> ppr u - ppr (RegLoc r) = ptext SLIT("reg") <+> pprMagicId r - ppr (VirHpLoc v) = ptext SLIT("vh") <+> ppr v - ppr (VirNodeLoc v) = ptext SLIT("vn") <+> ppr v + ppr (RegLoc r) = ptext SLIT("reg") <+> ppr r + ppr (VirHpLoc v) = ptext SLIT("vh") <+> ppr v + ppr (VirNodeLoc v) = ptext SLIT("vn") <+> ppr v instance Outputable StableLoc where - ppr NoStableLoc = empty - ppr (VirStkLoc v) = ptext SLIT("vs") <+> ppr v - ppr (LitLoc l) = ptext SLIT("lit") <+> ppr l - ppr (StableAmodeLoc a) = ptext SLIT("amode") <+> pprAmode a + ppr NoStableLoc = empty + ppr VoidLoc = ptext SLIT("void") + ppr (VirStkLoc v) = ptext SLIT("vs") <+> ppr v + ppr (VirStkLNE v) = ptext SLIT("lne") <+> ppr v + ppr (StableLoc a) = ptext SLIT("amode") <+> ppr a \end{code} %************************************************************************ @@ -133,41 +145,49 @@ instance Outputable StableLoc where %************************************************************************ \begin{code} -stableAmodeIdInfo i amode lf_info = MkCgIdInfo i NoVolatileLoc (StableAmodeLoc amode) lf_info -heapIdInfo i offset lf_info = MkCgIdInfo i (VirHpLoc offset) NoStableLoc lf_info -tempIdInfo i uniq lf_info = MkCgIdInfo i (TempVarLoc uniq) NoStableLoc lf_info - -letNoEscapeIdInfo i sp lf_info - = MkCgIdInfo i NoVolatileLoc (StableAmodeLoc (CJoinPoint sp)) lf_info - -idInfoToAmode :: PrimRep -> CgIdInfo -> FCode CAddrMode -idInfoToAmode kind (MkCgIdInfo _ vol stab _) = idInfoPiecesToAmode kind vol stab - -idInfoPiecesToAmode :: PrimRep -> VolatileLoc -> StableLoc -> FCode CAddrMode - -idInfoPiecesToAmode kind (TempVarLoc uniq) stable_loc = returnFC (CTemp uniq kind) -idInfoPiecesToAmode kind (RegLoc magic_id) stable_loc = returnFC (CReg magic_id) - -idInfoPiecesToAmode kind NoVolatileLoc (LitLoc lit) = returnFC (CLit lit) -idInfoPiecesToAmode kind NoVolatileLoc (StableAmodeLoc amode) = returnFC amode +stableIdInfo id amode lf_info = mkCgIdInfo id NoVolatileLoc (StableLoc amode) lf_info +heapIdInfo id offset lf_info = mkCgIdInfo id (VirHpLoc offset) NoStableLoc lf_info +letNoEscapeIdInfo id sp lf_info = mkCgIdInfo id NoVolatileLoc (VirStkLNE sp) lf_info +stackIdInfo id sp lf_info = mkCgIdInfo id NoVolatileLoc (VirStkLoc sp) lf_info +nodeIdInfo id offset lf_info = mkCgIdInfo id (VirNodeLoc offset) NoStableLoc lf_info +regIdInfo id reg lf_info = mkCgIdInfo id (RegLoc reg) NoStableLoc lf_info + +idInfoToAmode :: CgIdInfo -> FCode CmmExpr +idInfoToAmode info + = case cg_vol info of { + RegLoc reg -> returnFC (CmmReg reg) ; + VirNodeLoc nd_off -> returnFC (CmmLoad (cmmOffsetW (CmmReg nodeReg) nd_off) mach_rep) ; + VirHpLoc hp_off -> getHpRelOffset hp_off ; + NoVolatileLoc -> + + case cg_stb info of + StableLoc amode -> returnFC amode + VirStkLoc sp_off -> do { sp_rel <- getSpRelOffset sp_off + ; return (CmmLoad sp_rel mach_rep) } + + VirStkLNE sp_off -> getSpRelOffset sp_off ; + + VoidLoc -> return $ pprPanic "idInfoToAmode: void" (ppr (cg_id info)) + -- We return a 'bottom' amode, rather than panicing now + -- In this way getArgAmode returns a pair of (VoidArg, bottom) + -- and that's exactly what we want + + NoStableLoc -> pprPanic "idInfoToAmode: no loc" (ppr (cg_id info)) + } + where + mach_rep = argMachRep (cg_rep info) -idInfoPiecesToAmode kind (VirNodeLoc nd_off) stable_loc - = returnFC (CVal (nodeRel nd_off) kind) - -- Virtual offsets from Node increase into the closures, - -- and so do Node-relative offsets (which we want in the CVal), - -- so there is no mucking about to do to the offset. +cgIdInfoId :: CgIdInfo -> Id +cgIdInfoId = cg_id -idInfoPiecesToAmode kind (VirHpLoc hp_off) stable_loc - = getHpRelOffset hp_off `thenFC` \ rel_hp -> - returnFC (CAddr rel_hp) +cgIdInfoLF :: CgIdInfo -> LambdaFormInfo +cgIdInfoLF = cg_lf -idInfoPiecesToAmode kind NoVolatileLoc (VirStkLoc i) - = getSpRelOffset i `thenFC` \ rel_sp -> - returnFC (CVal rel_sp kind) +cgIdInfoArgRep :: CgIdInfo -> CgRep +cgIdInfoArgRep = cg_rep -#ifdef DEBUG -idInfoPiecesToAmode kind NoVolatileLoc NoStableLoc = panic "idInfoPiecesToAmode: no loc" -#endif +maybeLetNoEscape (CgIdInfo { cg_stb = VirStkLNE sp_off }) = Just sp_off +maybeLetNoEscape other = Nothing \end{code} %************************************************************************ @@ -176,8 +196,8 @@ idInfoPiecesToAmode kind NoVolatileLoc NoStableLoc = panic "idInfoPiecesToAmode: %* * %************************************************************************ -There are three basic routines, for adding (@addBindC@), modifying -(@modifyBindC@) and looking up (@lookupBindC@) bindings. +.There are three basic routines, for adding (@addBindC@), modifying +(@modifyBindC@) and looking up (@getCgIdInfo@) bindings. A @Id@ is bound to a @(VolatileLoc, StableLoc)@ triple. The name should not already be bound. (nice ASSERT, eh?) @@ -192,8 +212,8 @@ addBindsC :: [(Id, CgIdInfo)] -> Code addBindsC new_bindings = do binds <- getBinds let new_binds = foldl (\ binds (name,info) -> extendVarEnv binds name info) - binds - new_bindings + binds + new_bindings setBinds new_binds modifyBindC :: Id -> (CgIdInfo -> CgIdInfo) -> Code @@ -201,19 +221,34 @@ modifyBindC name mangle_fn = do binds <- getBinds setBinds $ modifyVarEnv mangle_fn binds name -lookupBindC :: Id -> FCode CgIdInfo -lookupBindC id = do maybe_info <- lookupBindC_maybe id - case maybe_info of - Just info -> return info - Nothing -> cgLookupPanic id - -lookupBindC_maybe :: Id -> FCode (Maybe CgIdInfo) -lookupBindC_maybe id - = do static_binds <- getStaticBinds - local_binds <- getBinds - return (lookupVarEnv local_binds id - `seqMaybe` - lookupVarEnv static_binds id) +getCgIdInfo :: Id -> FCode CgIdInfo +getCgIdInfo id + = do { -- Try local bindings first + ; local_binds <- getBinds + ; case lookupVarEnv local_binds id of { + Just info -> return info ; + Nothing -> do + + { -- Try top-level bindings + static_binds <- getStaticBinds + ; case lookupVarEnv static_binds id of { + Just info -> return info ; + Nothing -> + + -- Should be imported; make up a CgIdInfo for it + if isExternalName name then + return (stableIdInfo id ext_lbl (mkLFImported id)) + else + if isVoidArg (idCgRep id) then + -- Void things are never in the environment + return (voidIdInfo id) + else + -- Bug + cgLookupPanic id + }}}} + where + name = idName id + ext_lbl = CmmLit (CmmLabel (mkClosureLabel name)) cgLookupPanic :: Id -> FCode a cgLookupPanic id @@ -223,9 +258,9 @@ cgLookupPanic id pprPanic "cgPanic" (vcat [ppr id, ptext SLIT("static binds for:"), - vcat [ ppr i | (MkCgIdInfo i _ _ _) <- rngVarEnv static_binds ], + vcat [ ppr (cg_id info) | info <- rngVarEnv static_binds ], ptext SLIT("local binds for:"), - vcat [ ppr i | (MkCgIdInfo i _ _ _) <- rngVarEnv local_binds ], + vcat [ ppr (cg_id info) | info <- rngVarEnv local_binds ], ptext SLIT("SRT label") <+> pprCLabel srt ]) \end{code} @@ -244,9 +279,9 @@ nukeVolatileBinds :: CgBindings -> CgBindings nukeVolatileBinds binds = mkVarEnv (foldr keep_if_stable [] (rngVarEnv binds)) where - keep_if_stable (MkCgIdInfo i _ NoStableLoc entry_info) acc = acc - keep_if_stable (MkCgIdInfo i _ stable_loc entry_info) acc - = (i, MkCgIdInfo i NoVolatileLoc stable_loc entry_info) : acc + keep_if_stable (CgIdInfo { cg_stb = NoStableLoc }) acc = acc + keep_if_stable info acc + = (cg_id info, info { cg_vol = NoVolatileLoc }) : acc \end{code} @@ -256,46 +291,15 @@ nukeVolatileBinds binds %* * %************************************************************************ -I {\em think} all looking-up is done through @getCAddrMode(s)@. - \begin{code} -getCAddrModeAndInfo :: Id -> FCode (Id, CAddrMode, LambdaFormInfo) - -getCAddrModeAndInfo id - = do - maybe_cg_id_info <- lookupBindC_maybe id - case maybe_cg_id_info of - - -- Nothing => not in the environment, so should be imported - Nothing | isInternalName name -> cgLookupPanic id - | otherwise -> returnFC (id, global_amode, mkLFImported id) - - Just (MkCgIdInfo id' volatile_loc stable_loc lf_info) - -> do amode <- idInfoPiecesToAmode kind volatile_loc stable_loc - return (id', amode, lf_info) - where - name = getName id - global_amode = CLbl (mkClosureLabel name) kind - kind = idPrimRep id - -getCAddrMode :: Id -> FCode CAddrMode -getCAddrMode name = do - (_, amode, _) <- getCAddrModeAndInfo name - return amode -\end{code} - -\begin{code} -getCAddrModeIfVolatile :: Id -> FCode (Maybe CAddrMode) -getCAddrModeIfVolatile name --- | toplevelishId name = returnFC Nothing --- | otherwise - = do - (MkCgIdInfo _ volatile_loc stable_loc lf_info) <- lookupBindC name - case stable_loc of +getCAddrModeIfVolatile :: Id -> FCode (Maybe CmmExpr) +getCAddrModeIfVolatile id + = do { info <- getCgIdInfo id + ; case cg_stb info of NoStableLoc -> do -- Aha! So it is volatile! - amode <- idInfoPiecesToAmode (idPrimRep name) volatile_loc NoStableLoc + amode <- idInfoToAmode info return $ Just amode - a_stable_loc -> return Nothing + a_stable_loc -> return Nothing } \end{code} @getVolatileRegs@ gets a set of live variables, and returns a list of @@ -306,56 +310,57 @@ stable one (notably, on the stack), we modify the current bindings to forget the volatile one. \begin{code} -getVolatileRegs :: StgLiveVars -> FCode [MagicId] +getVolatileRegs :: StgLiveVars -> FCode [GlobalReg] getVolatileRegs vars = do - stuff <- mapFCs snaffle_it (varSetElems vars) - returnFC $ catMaybes stuff - where - snaffle_it var = do - (MkCgIdInfo _ volatile_loc stable_loc lf_info) <- lookupBindC var - let + do { stuff <- mapFCs snaffle_it (varSetElems vars) + ; returnFC $ catMaybes stuff } + where + snaffle_it var = do + { info <- getCgIdInfo var + ; let -- commoned-up code... - consider_reg reg = - if not (isVolatileReg reg) then - -- Potentially dies across C calls - -- For now, that's everything; we leave - -- it to the save-macros to decide which - -- regs *really* need to be saved. - returnFC Nothing - else - case stable_loc of - NoStableLoc -> returnFC (Just reg) -- got one! - is_a_stable_loc -> do - -- has both volatile & stable locations; - -- force it to rely on the stable location - modifyBindC var nuke_vol_bind - return Nothing - in - case volatile_loc of - RegLoc reg -> consider_reg reg - VirNodeLoc _ -> consider_reg node - non_reg_loc -> returnFC Nothing - - nuke_vol_bind (MkCgIdInfo i _ stable_loc lf_info) - = MkCgIdInfo i NoVolatileLoc stable_loc lf_info + consider_reg reg + = -- We assume that all regs can die across C calls + -- We leave it to the save-macros to decide which + -- regs *really* need to be saved. + case cg_stb info of + NoStableLoc -> returnFC (Just reg) -- got one! + is_a_stable_loc -> do + { -- has both volatile & stable locations; + -- force it to rely on the stable location + modifyBindC var nuke_vol_bind + ; return Nothing } + + ; case cg_vol info of + RegLoc (CmmGlobal reg) -> consider_reg reg + VirNodeLoc _ -> consider_reg node + other_loc -> returnFC Nothing -- Local registers + } + + nuke_vol_bind info = info { cg_vol = NoVolatileLoc } \end{code} \begin{code} -getArgAmodes :: [StgArg] -> FCode [CAddrMode] -getArgAmodes [] = returnFC [] -getArgAmodes (atom:atoms) - | isStgTypeArg atom - = getArgAmodes atoms - | otherwise = do - amode <- getArgAmode atom - amodes <- getArgAmodes atoms - return ( amode : amodes ) +getArgAmode :: StgArg -> FCode (CgRep, CmmExpr) +getArgAmode (StgVarArg var) + = do { info <- getCgIdInfo var + ; amode <- idInfoToAmode info + ; return (cgIdInfoArgRep info, amode ) } -getArgAmode :: StgArg -> FCode CAddrMode +getArgAmode (StgLitArg lit) + = do { cmm_lit <- cgLit lit + ; return (typeCgRep (literalType lit), CmmLit cmm_lit) } -getArgAmode (StgVarArg var) = getCAddrMode var -- The common case -getArgAmode (StgLitArg lit) = returnFC (CLit lit) +getArgAmode (StgTypeArg _) = panic "getArgAmode: type arg" + +getArgAmodes :: [StgArg] -> FCode [(CgRep, CmmExpr)] +getArgAmodes [] = returnFC [] +getArgAmodes (atom:atoms) + | isStgTypeArg atom = getArgAmodes atoms + | otherwise = do { amode <- getArgAmode atom + ; amodes <- getArgAmodes atoms + ; return ( amode : amodes ) } \end{code} %************************************************************************ @@ -365,43 +370,40 @@ getArgAmode (StgLitArg lit) = returnFC (CLit lit) %************************************************************************ \begin{code} -bindNewToStack :: (Id, VirtualSpOffset) -> Code -bindNewToStack (name, offset) - = addBindC name info +bindArgsToStack :: [(Id, VirtualSpOffset)] -> Code +bindArgsToStack args + = mapCs bind args where - info = MkCgIdInfo name NoVolatileLoc (VirStkLoc offset) (mkLFArgument name) + bind(id, offset) = addBindC id (stackIdInfo id offset (mkLFArgument id)) -bindNewToNode :: Id -> VirtualHeapOffset -> LambdaFormInfo -> Code -bindNewToNode name offset lf_info - = addBindC name info +bindArgsToRegs :: [(Id, GlobalReg)] -> Code +bindArgsToRegs args + = mapCs bind args where - info = MkCgIdInfo name (VirNodeLoc offset) NoStableLoc lf_info + bind (arg, reg) = bindNewToReg arg (CmmGlobal reg) (mkLFArgument arg) + +bindNewToNode :: Id -> VirtualHpOffset -> LambdaFormInfo -> Code +bindNewToNode id offset lf_info + = addBindC id (nodeIdInfo id offset lf_info) -- Create a new temporary whose unique is that in the id, -- bind the id to it, and return the addressing mode for the -- temporary. -bindNewToTemp :: Id -> FCode CAddrMode +bindNewToTemp :: Id -> FCode CmmReg bindNewToTemp id - = do addBindC id id_info - return temp_amode - where - uniq = getUnique id - temp_amode = CTemp uniq (idPrimRep id) - id_info = tempIdInfo id uniq lf_info - lf_info = mkLFArgument id -- Always used of things we - -- know nothing about - -bindNewToReg :: Id -> MagicId -> LambdaFormInfo -> Code -bindNewToReg name magic_id lf_info - = addBindC name info + = do addBindC id (regIdInfo id temp_reg lf_info) + return temp_reg where - info = MkCgIdInfo name (RegLoc magic_id) NoStableLoc lf_info + uniq = getUnique id + temp_reg = CmmLocal (LocalReg uniq (argMachRep (idCgRep id))) + lf_info = mkLFArgument id -- Always used of things we + -- know nothing about -bindArgsToRegs :: [Id] -> [MagicId] -> Code -bindArgsToRegs args regs - = listCs (zipWithEqual "bindArgsToRegs" bind args regs) +bindNewToReg :: Id -> CmmReg -> LambdaFormInfo -> Code +bindNewToReg name reg lf_info + = addBindC name info where - arg `bind` reg = bindNewToReg arg reg (mkLFArgument arg) + info = mkCgIdInfo name (RegLoc reg) NoStableLoc lf_info \end{code} \begin{code} @@ -409,69 +411,7 @@ rebindToStack :: Id -> VirtualSpOffset -> Code rebindToStack name offset = modifyBindC name replace_stable_fn where - replace_stable_fn (MkCgIdInfo i vol stab einfo) - = MkCgIdInfo i vol (VirStkLoc offset) einfo -\end{code} - -%************************************************************************ -%* * -\subsection[CgBindery-liveness]{Build a liveness mask for the current stack} -%* * -%************************************************************************ - -There are four kinds of things on the stack: - - - pointer variables (bound in the environment) - - non-pointer variables (boudn in the environment) - - free slots (recorded in the stack free list) - - non-pointer data slots (recorded in the stack free list) - -We build up a bitmap of non-pointer slots by searching the environment -for all the pointer variables, and subtracting these from a bitmap -with initially all bits set (up to the size of the stack frame). - -\begin{code} -buildLivenessMask - :: VirtualSpOffset -- size of the stack frame - -> VirtualSpOffset -- offset from which the bitmap should start - -> FCode Bitmap -- mask for free/unlifted slots - -buildLivenessMask size sp = do { - -- find all live stack-resident pointers - binds <- getBinds; - ((vsp, _, free, _, _), heap_usage) <- getUsage; - - let { - rel_slots = sortLt (<) - [ sp - ofs -- get slots relative to top of frame - | (MkCgIdInfo id _ (VirStkLoc ofs) _) <- rngVarEnv binds, - isFollowableRep (idPrimRep id) - ]; - }; - - WARN( not (all (>=0) rel_slots), ppr size $$ ppr sp $$ ppr rel_slots $$ ppr binds ) - return (intsToReverseBitmap size rel_slots) - } - --- In a continuation, we want a liveness mask that starts from just after --- the return address, which is on the stack at realSp. - -buildContLivenessMask :: Id -> FCode Liveness - -- The Id is used just for its unique to make a label -buildContLivenessMask id = do - realSp <- getRealSp - - frame_sp <- getStackFrame - -- realSp points to the frame-header for the current stack frame, - -- and the end of this frame is frame_sp. The size is therefore - -- realSp - frame_sp - 1 (subtract one for the frame-header). - let frame_size = realSp - frame_sp - 1 - - mask <- buildLivenessMask frame_size (realSp-1) - - let liveness = Liveness (mkBitmapLabel (getName id)) frame_size mask - absC (maybeLargeBitmap liveness) - return liveness + replace_stable_fn info = info { cg_stb = VirStkLoc offset } \end{code} %************************************************************************ @@ -503,7 +443,7 @@ nukeDeadBindings live_vars = do let (dead_stk_slots, bs') = dead_slots live_vars [] [] - [ (i, b) | b@(MkCgIdInfo i _ _ _) <- rngVarEnv binds ] + [ (cg_id b, b) | b <- rngVarEnv binds ] setBinds $ mkVarEnv bs' freeStackSlots dead_stk_slots \end{code} @@ -529,19 +469,23 @@ dead_slots live_vars fbs ds ((v,i):bs) -- Instead keep it in the filtered bindings | otherwise - = case i of - MkCgIdInfo _ _ stable_loc _ - | is_stk_loc && size > 0 -> - dead_slots live_vars fbs ([offset-size+1 .. offset] ++ ds) bs - where - maybe_stk_loc = maybeStkLoc stable_loc - is_stk_loc = maybeToBool maybe_stk_loc - (Just offset) = maybe_stk_loc + = case cg_stb i of + VirStkLoc offset + | size > 0 + -> dead_slots live_vars fbs ([offset-size+1 .. offset] ++ ds) bs _ -> dead_slots live_vars fbs ds bs where + size :: WordOff + size = cgRepSizeW (cg_rep i) +\end{code} - size :: Int - size = (getPrimRepSize . typePrimRep . idType) v - +\begin{code} +getLiveStackSlots :: FCode [VirtualSpOffset] +-- Return the offsets of slots in stack containig live pointers +getLiveStackSlots + = do { binds <- getBinds + ; return [off | CgIdInfo { cg_stb = VirStkLoc off, + cg_rep = rep } <- rngVarEnv binds, + isFollowableArg rep] } \end{code} diff --git a/ghc/compiler/codeGen/CgCallConv.hs b/ghc/compiler/codeGen/CgCallConv.hs new file mode 100644 index 0000000000..fa98f96378 --- /dev/null +++ b/ghc/compiler/codeGen/CgCallConv.hs @@ -0,0 +1,507 @@ +----------------------------------------------------------------------------- +-- +-- CgCallConv +-- +-- The datatypes and functions here encapsulate the +-- calling and return conventions used by the code generator. +-- +-- (c) The University of Glasgow 2004 +-- +----------------------------------------------------------------------------- + + +module CgCallConv ( + -- Argument descriptors + mkArgDescr, argDescrType, + + -- Liveness + isBigLiveness, buildContLiveness, mkRegLiveness, + smallLiveness, mkLivenessCLit, + + -- Register assignment + assignCallRegs, assignReturnRegs, assignPrimOpCallRegs, + + -- Calls + constructSlowCall, slowArgs, slowCallPattern, + + -- Returns + CtrlReturnConvention(..), + ctrlReturnConvAlg, + dataReturnConvPrim, + getSequelAmode + ) where + +#include "HsVersions.h" + +import CgUtils ( emitRODataLits, mkWordCLit ) +import CgMonad + +import Constants ( mAX_FAMILY_SIZE_FOR_VEC_RETURNS, + mAX_Vanilla_REG, mAX_Float_REG, + mAX_Double_REG, mAX_Long_REG, + mAX_Real_Vanilla_REG, mAX_Real_Float_REG, + mAX_Real_Double_REG, mAX_Real_Long_REG, + bITMAP_BITS_SHIFT + ) + +import ClosureInfo ( ArgDescr(..), Liveness(..) ) +import CgStackery ( getSpRelOffset ) +import SMRep +import MachOp ( wordRep ) +import Cmm ( CmmExpr(..), GlobalReg(..), CmmLit(..), CmmReg(..), node ) +import CmmUtils ( mkLblExpr ) +import CLabel +import Maybes ( mapCatMaybes ) +import Id ( Id ) +import Name ( Name ) +import TyCon ( TyCon, tyConFamilySize ) +import Bitmap ( Bitmap, mAX_SMALL_BITMAP_SIZE, + mkBitmap, intsToReverseBitmap ) +import Util ( isn'tIn, sortLt ) +import CmdLineOpts ( opt_Unregisterised ) +import FastString ( LitString ) +import Outputable +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/StgFun.h" + +------------------------- +argDescrType :: ArgDescr -> Int +-- The "argument type" RTS field type +argDescrType (ArgSpec n) = n +argDescrType (ArgGen liveness) + | isBigLiveness liveness = ARG_GEN_BIG + | otherwise = ARG_GEN + + +mkArgDescr :: Name -> [Id] -> FCode ArgDescr +mkArgDescr nm args + = case stdPattern arg_reps of + Just spec_id -> return (ArgSpec spec_id) + Nothing -> do { liveness <- mkLiveness nm size bitmap + ; return (ArgGen liveness) } + where + arg_reps = filter nonVoidArg (map idCgRep args) + -- Getting rid of voids eases matching of standard patterns + + bitmap = mkBitmap arg_bits + arg_bits = argBits arg_reps + size = length arg_bits + +argBits :: [CgRep] -> [Bool] -- True for non-ptr, False for ptr +argBits [] = [] +argBits (PtrArg : args) = False : argBits args +argBits (arg : args) = take (cgRepSizeW arg) (repeat True) ++ argBits args + +stdPattern :: [CgRep] -> Maybe Int +stdPattern [PtrArg] = Just ARG_P +stdPattern [FloatArg] = Just ARG_F +stdPattern [DoubleArg] = Just ARG_D +stdPattern [LongArg] = Just ARG_L +stdPattern [NonPtrArg] = Just ARG_N + +stdPattern [NonPtrArg,NonPtrArg] = Just ARG_NN +stdPattern [NonPtrArg,PtrArg] = Just ARG_NP +stdPattern [PtrArg,NonPtrArg] = Just ARG_PN +stdPattern [PtrArg,PtrArg] = Just ARG_PP + +stdPattern [NonPtrArg,NonPtrArg,NonPtrArg] = Just ARG_NNN +stdPattern [NonPtrArg,NonPtrArg,PtrArg] = Just ARG_NNP +stdPattern [NonPtrArg,PtrArg,NonPtrArg] = Just ARG_NPN +stdPattern [NonPtrArg,PtrArg,PtrArg] = Just ARG_NPP +stdPattern [PtrArg,NonPtrArg,NonPtrArg] = Just ARG_PNN +stdPattern [PtrArg,NonPtrArg,PtrArg] = Just ARG_PNP +stdPattern [PtrArg,PtrArg,NonPtrArg] = Just ARG_PPN +stdPattern [PtrArg,PtrArg,PtrArg] = Just ARG_PPP + +stdPattern [PtrArg,PtrArg,PtrArg,PtrArg] = Just ARG_PPPP +stdPattern [PtrArg,PtrArg,PtrArg,PtrArg,PtrArg] = Just ARG_PPPPP +stdPattern [PtrArg,PtrArg,PtrArg,PtrArg,PtrArg,PtrArg] = Just ARG_PPPPPP +stdPattern other = Nothing + + +------------------------------------------------------------------------- +-- +-- Liveness info +-- +------------------------------------------------------------------------- + +mkLiveness :: Name -> Int -> Bitmap -> FCode Liveness +mkLiveness name size bits + | size > mAX_SMALL_BITMAP_SIZE -- Bitmap does not fit in one word + = do { let lbl = mkBitmapLabel name + ; emitRODataLits lbl ( mkWordCLit (fromIntegral size) + : map mkWordCLit bits) + ; return (BigLiveness lbl) } + + | otherwise -- Bitmap fits in one word + = let + small_bits = case bits of + [] -> 0 + [b] -> fromIntegral b + _ -> panic "livenessToAddrMode" + in + return (smallLiveness size small_bits) + +smallLiveness :: Int -> StgWord -> Liveness +smallLiveness size small_bits = SmallLiveness bits + where bits = fromIntegral size .|. (small_bits `shiftL` bITMAP_BITS_SHIFT) + +------------------- +isBigLiveness :: Liveness -> Bool +isBigLiveness (BigLiveness _) = True +isBigLiveness (SmallLiveness _) = False + +------------------- +mkLivenessCLit :: Liveness -> CmmLit +mkLivenessCLit (BigLiveness lbl) = CmmLabel lbl +mkLivenessCLit (SmallLiveness bits) = mkWordCLit bits + + +------------------------------------------------------------------------- +-- +-- 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 :: [(Id, GlobalReg)] -> Int -> Int -> StgWord +mkRegLiveness regs ptrs nptrs + = (fromIntegral nptrs `shiftL` 16) .|. + (fromIntegral ptrs `shiftL` 24) .|. + all_non_ptrs `xor` reg_bits regs + where + all_non_ptrs = 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__ret_info return addresses. +constructSlowCall :: [(CgRep,CmmExpr)] -> (CLabel, [(CgRep,CmmExpr)]) + -- don't forget the zero case +constructSlowCall [] + = (stg_ap_0, []) + where + stg_ap_0 = enterRtsRetLabel SLIT("stg_ap_0") + +constructSlowCall amodes + = (stg_ap_pat, these ++ slowArgs rest) + where + stg_ap_pat = enterRtsRetLabel arg_pat + (arg_pat, these, rest) = matchSlowPattern amodes + +enterRtsRetLabel arg_pat + | tablesNextToCode = mkRtsRetInfoLabel arg_pat + | otherwise = mkRtsRetLabel arg_pat + +-- | '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 :: [(CgRep,CmmExpr)] -> [(CgRep,CmmExpr)] +slowArgs [] = [] +slowArgs amodes = (NonPtrArg, mkLblExpr stg_ap_pat) : args ++ slowArgs rest + where (arg_pat, args, rest) = matchSlowPattern amodes + stg_ap_pat = mkRtsRetInfoLabel arg_pat + +matchSlowPattern :: [(CgRep,CmmExpr)] + -> (LitString, [(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 (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _) = (SLIT("stg_ap_pppppp"), 6) +slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _) = (SLIT("stg_ap_ppppp"), 5) +slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: _) = (SLIT("stg_ap_pppp"), 4) +slowCallPattern (PtrArg: PtrArg: PtrArg: VoidArg: _) = (SLIT("stg_ap_pppv"), 4) +slowCallPattern (PtrArg: PtrArg: PtrArg: _) = (SLIT("stg_ap_ppp"), 3) +slowCallPattern (PtrArg: PtrArg: VoidArg: _) = (SLIT("stg_ap_ppv"), 3) +slowCallPattern (PtrArg: PtrArg: _) = (SLIT("stg_ap_pp"), 2) +slowCallPattern (PtrArg: VoidArg: _) = (SLIT("stg_ap_pv"), 2) +slowCallPattern (PtrArg: _) = (SLIT("stg_ap_p"), 1) +slowCallPattern (VoidArg: _) = (SLIT("stg_ap_v"), 1) +slowCallPattern (NonPtrArg: _) = (SLIT("stg_ap_n"), 1) +slowCallPattern (FloatArg: _) = (SLIT("stg_ap_f"), 1) +slowCallPattern (DoubleArg: _) = (SLIT("stg_ap_d"), 1) +slowCallPattern (LongArg: _) = (SLIT("stg_ap_l"), 1) +slowCallPattern _ = panic "CgStackery.slowCallPattern" + +------------------------------------------------------------------------- +-- +-- Return conventions +-- +------------------------------------------------------------------------- + +-- A @CtrlReturnConvention@ says how {\em control} is returned. + +data CtrlReturnConvention + = VectoredReturn Int -- size of the vector table (family size) + | UnvectoredReturn Int -- family size + +ctrlReturnConvAlg :: TyCon -> CtrlReturnConvention +ctrlReturnConvAlg tycon + = case (tyConFamilySize tycon) of + size -> -- we're supposed to know... + if (size > (1::Int) && size <= mAX_FAMILY_SIZE_FOR_VEC_RETURNS) then + VectoredReturn size + else + UnvectoredReturn size + -- NB: unvectored returns Include size 0 (no constructors), so that + -- the following perverse code compiles (it crashed GHC in 5.02) + -- data T1 + -- data T2 = T2 !T1 Int + -- The only value of type T1 is bottom, which never returns anyway. + +dataReturnConvPrim :: CgRep -> CmmReg +dataReturnConvPrim PtrArg = CmmGlobal (VanillaReg 1) +dataReturnConvPrim NonPtrArg = CmmGlobal (VanillaReg 1) +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(_VEC)?_(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 { sp_rel <- getSpRelOffset virt_sp + ; returnFC (CmmLoad sp_rel wordRep) } + + UpdateCode -> returnFC (CmmLit (CmmLabel mkUpdInfoLabel)) + CaseAlts lbl _ _ True -> returnFC (CmmLit (CmmLabel mkSeqInfoLabel)) + CaseAlts lbl _ _ False -> returnFC (CmmLit (CmmLabel lbl)) + } + +------------------------------------------------------------------------- +-- +-- Build a liveness mask for the current stack +-- +------------------------------------------------------------------------- + +-- There are four kinds of things on the stack: +-- +-- - pointer variables (bound in the environment) +-- - non-pointer variables (boudn in the environment) +-- - free slots (recorded in the stack free list) +-- - non-pointer data slots (recorded in the stack free list) +-- +-- We build up a bitmap of non-pointer slots by searching the environment +-- for all the pointer variables, and subtracting these from a bitmap +-- with initially all bits set (up to the size of the stack frame). + +buildContLiveness :: Name -- Basis for label (only) + -> [VirtualSpOffset] -- Live stack slots + -> FCode Liveness +buildContLiveness name live_slots + = do { stk_usg <- getStkUsage + ; let StackUsage { realSp = real_sp, + frameSp = frame_sp } = stk_usg + + start_sp :: VirtualSpOffset + start_sp = real_sp - retAddrSizeW + -- In a continuation, we want a liveness mask that + -- starts from just after the return address, which is + -- on the stack at real_sp. + + frame_size :: WordOff + frame_size = start_sp - frame_sp + -- real_sp points to the frame-header for the current + -- stack frame, and the end of this frame is frame_sp. + -- The size is therefore real_sp - frame_sp - retAddrSizeW + -- (subtract one for the frame-header = return address). + + rel_slots :: [WordOff] + rel_slots = sortLt (<) + [ start_sp - ofs -- Get slots relative to top of frame + | ofs <- live_slots ] + + bitmap = intsToReverseBitmap frame_size rel_slots + + ; WARN( not (all (>=0) rel_slots), + ppr name $$ ppr live_slots $$ ppr frame_size $$ ppr start_sp $$ ppr rel_slots ) + mkLiveness name frame_size bitmap } + + +------------------------------------------------------------------------- +-- +-- 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. + +assignCallRegs, assignPrimOpCallRegs, assignReturnRegs + :: [(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 args + = assign_regs args (mkRegTbl [node]) + -- The entry convention for a function closure + -- never uses Node for argument passing; instead + -- Node points to the function closure itself + +assignPrimOpCallRegs args + = assign_regs args (mkRegTbl_allRegs []) + -- For primops, *all* arguments must be passed in registers + +assignReturnRegs args + = assign_regs args (mkRegTbl []) + -- For returning unboxed tuples etc, + -- we use all regs + +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 supply = (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 nothign 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, (vs, fs, ds, ls)) +assign_reg NonPtrArg (v:vs, fs, ds, ls) = Just (VanillaReg v, (vs, fs, ds, ls)) + -- PtrArg and NonPtrArg both go in a vanilla register +assign_reg other not_enough_regs = 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 | opt_Unregisterised = 0 + | otherwise = mAX_Real_Vanilla_REG +useFloatRegs | opt_Unregisterised = 0 + | otherwise = mAX_Real_Float_REG +useDoubleRegs | opt_Unregisterised = 0 + | otherwise = mAX_Real_Double_REG +useLongRegs | opt_Unregisterised = 0 + | otherwise = mAX_Real_Long_REG + +vanillaRegNos, floatRegNos, doubleRegNos, longRegNos :: [Int] +vanillaRegNos = regList useVanillaRegs +floatRegNos = regList useFloatRegs +doubleRegNos = regList useDoubleRegs +longRegNos = regList useLongRegs + +allVanillaRegNos, allFloatRegNos, allDoubleRegNos, allLongRegNos :: [Int] +allVanillaRegNos = regList mAX_Vanilla_REG +allFloatRegNos = regList mAX_Float_REG +allDoubleRegNos = regList mAX_Double_REG +allLongRegNos = regList mAX_Long_REG + +regList 0 = [] +regList n = [1 .. n] + +type AvailRegs = ( [Int] -- available vanilla regs. + , [Int] -- floats + , [Int] -- doubles + , [Int] -- longs (int64 and word64) + ) + +mkRegTbl :: [GlobalReg] -> AvailRegs +mkRegTbl regs_in_use + = mkRegTbl' regs_in_use vanillaRegNos floatRegNos doubleRegNos longRegNos + +mkRegTbl_allRegs :: [GlobalReg] -> AvailRegs +mkRegTbl_allRegs regs_in_use + = mkRegTbl' regs_in_use allVanillaRegNos allFloatRegNos allDoubleRegNos allLongRegNos + +mkRegTbl' regs_in_use vanillas floats doubles longs + = (ok_vanilla, ok_float, ok_double, ok_long) + where + ok_vanilla = mapCatMaybes (select VanillaReg) vanillas + ok_float = mapCatMaybes (select FloatReg) floats + ok_double = mapCatMaybes (select DoubleReg) doubles + ok_long = mapCatMaybes (select LongReg) longs + -- rep isn't looked at, hence we can use any old rep. + + 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" + + diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs index c805aaa413..c7b03ef13a 100644 --- a/ghc/compiler/codeGen/CgCase.lhs +++ b/ghc/compiler/codeGen/CgCase.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgCase.lhs,v 1.68 2004/08/10 09:02:38 simonmar Exp $ +% $Id: CgCase.lhs,v 1.69 2004/08/13 13:05:51 simonmar Exp $ % %******************************************************** %* * @@ -11,7 +11,7 @@ \begin{code} module CgCase ( cgCase, saveVolatileVarsAndRegs, - mkRetDirectTarget, restoreCurrentCostCentre + restoreCurrentCostCentre ) where #include "HsVersions.h" @@ -20,43 +20,42 @@ import {-# SOURCE #-} CgExpr ( cgExpr ) import CgMonad import StgSyn -import AbsCSyn - -import AbsCUtils ( mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch, - getAmodeRep, shimFCallArg ) -import CgBindery ( getVolatileRegs, getArgAmodes, +import CgBindery ( getArgAmodes, bindNewToReg, bindNewToTemp, - getCAddrModeAndInfo, - rebindToStack, getCAddrMode, getCAddrModeIfVolatile, - buildContLivenessMask, nukeDeadBindings, + getCgIdInfo, getArgAmode, + rebindToStack, getCAddrModeIfVolatile, + nukeDeadBindings, idInfoToAmode ) import CgCon ( bindConArgs, bindUnboxedTupleComponents ) import CgHeapery ( altHeapCheck, unbxTupleHeapCheck ) -import CgRetConv ( dataReturnConvPrim, ctrlReturnConvAlg, +import CgCallConv ( dataReturnConvPrim, ctrlReturnConvAlg, CtrlReturnConvention(..) ) -import CgStackery ( allocPrimStack, allocStackTop, - deAllocStackTop, freeStackSlots, dataStackSlots +import CgStackery ( allocPrimStack, allocStackTop, getSpRelOffset, + deAllocStackTop, freeStackSlots ) import CgTailCall ( performTailCall ) -import CgUsages ( getSpRelOffset ) -import CLabel ( mkVecTblLabel, mkClosureTblLabel, - mkDefaultLabel, mkAltLabel, mkReturnInfoLabel - ) +import CgPrimOp ( cgPrimOp ) +import CgForeignCall ( cgForeignCall ) +import CgUtils ( newTemp, cgLit, emitLitSwitch, emitSwitch, + tagToClosure ) +import CgProf ( curCCS, curCCSAddr ) +import CgInfoTbls ( emitDirectReturnTarget, emitAlgReturnTarget, + dataConTagZ ) +import SMRep ( CgRep(..), retAddrSizeW, nonVoidArg, isVoidArg, + idCgRep, tyConCgRep, typeHint ) +import CmmUtils ( CmmStmts, noStmts, oneStmt, plusStmts ) +import Cmm +import MachOp ( wordRep ) import ClosureInfo ( mkLFArgument ) import CmdLineOpts ( opt_SccProfilingOn ) -import Id ( Id, idName, isDeadBinder ) -import DataCon ( dataConTag, fIRST_TAG, ConTag ) +import Id ( Id, idName, isDeadBinder, idType ) +import ForeignCall ( ForeignCall(..), CCallSpec(..), playSafe ) import VarSet ( varSetElems ) import CoreSyn ( AltCon(..) ) -import PrimOp ( primOpOutOfLine, PrimOp(..) ) -import PrimRep ( getPrimRepSize, retPrimRepSize, PrimRep(..) - ) -import TyCon ( TyCon, isEnumerationTyCon, tyConPrimRep ) -import Unique ( Unique, Uniquable(..), newTagUnique ) -import ForeignCall -import Util ( only ) -import List ( sortBy ) +import PrimOp ( PrimOp(..), primOpOutOfLine ) +import TyCon ( isEnumerationTyCon, tyConFamilySize ) +import Util ( isSingleton ) import Outputable \end{code} @@ -122,10 +121,11 @@ Special case #1: case of literal. \begin{code} cgCase (StgLit lit) live_in_whole_case live_in_alts bndr srt - alt_type@(PrimAlt tycon) alts - = bindNewToTemp bndr `thenFC` \ tmp_amode -> - absC (CAssign tmp_amode (CLit lit)) `thenC` - cgPrimAlts NoGC tmp_amode alts alt_type + alt_type@(PrimAlt tycon) alts + = do { tmp_reg <- bindNewToTemp bndr + ; cm_lit <- cgLit lit + ; stmtC (CmmAssign tmp_reg (CmmLit cm_lit)) + ; cgPrimAlts NoGC alt_type tmp_reg alts } \end{code} Special case #2: scrutinising a primitive-typed variable. No @@ -138,15 +138,15 @@ eliminate a heap check altogether. \begin{code} cgCase (StgApp v []) live_in_whole_case live_in_alts bndr srt alt_type@(PrimAlt tycon) alts - - = -- Careful! we can't just bind the default binder to the same thing - -- as the scrutinee, since it might be a stack location, and having - -- two bindings pointing at the same stack locn doesn't work (it - -- confuses nukeDeadBindings). Hence, use a new temp. - getCAddrMode v `thenFC` \ amode -> - bindNewToTemp bndr `thenFC` \ tmp_amode -> - absC (CAssign tmp_amode amode) `thenC` - cgPrimAlts NoGC tmp_amode alts alt_type + = do { -- Careful! we can't just bind the default binder to the same thing + -- as the scrutinee, since it might be a stack location, and having + -- two bindings pointing at the same stack locn doesn't work (it + -- confuses nukeDeadBindings). Hence, use a new temp. + v_info <- getCgIdInfo v + ; amode <- idInfoToAmode v_info + ; tmp_reg <- bindNewToTemp bndr + ; stmtC (CmmAssign tmp_reg amode) + ; cgPrimAlts NoGC alt_type tmp_reg alts } \end{code} Special case #3: inline PrimOps and foreign calls. @@ -154,85 +154,8 @@ Special case #3: inline PrimOps and foreign calls. \begin{code} cgCase (StgOpApp op args _) live_in_whole_case live_in_alts bndr srt alt_type alts - | inline_primop - = -- Get amodes for the arguments and results - getArgAmodes args `thenFC` \ arg_amodes1 -> - let - arg_amodes - | StgFCallOp{} <- op = zipWith shimFCallArg args arg_amodes1 - | otherwise = arg_amodes1 - in - getVolatileRegs live_in_alts `thenFC` \ vol_regs -> - - case alt_type of - PrimAlt tycon -- PRIMITIVE ALTS - -> bindNewToTemp bndr `thenFC` \ tmp_amode -> - absC (COpStmt [tmp_amode] op arg_amodes vol_regs) `thenC` - -- Note: no liveness arg - cgPrimAlts NoGC tmp_amode alts alt_type - - UbxTupAlt tycon -- UNBOXED TUPLE ALTS - -> -- No heap check, no yield, just get in there and do it. - -- NB: the case binder isn't bound to anything; - -- it has a unboxed tuple type - mapFCs bindNewToTemp res_ids `thenFC` \ res_tmps -> - absC (COpStmt res_tmps op arg_amodes vol_regs) `thenC` - cgExpr rhs - where - [(_, res_ids, _, rhs)] = alts - - AlgAlt tycon -- ENUMERATION TYPE RETURN - | StgPrimOp primop <- op - -> ASSERT( isEnumerationTyCon tycon ) - let - do_enum_primop :: PrimOp -> FCode CAddrMode -- Returns amode for result - do_enum_primop TagToEnumOp -- No code! - = returnFC (only arg_amodes) - - do_enum_primop primop - = absC (COpStmt [tag_amode] op arg_amodes vol_regs) `thenC` - returnFC tag_amode - where - tag_amode = CTemp (newTagUnique (getUnique bndr) 'C') IntRep - -- Being a bit short of uniques for temporary - -- variables here, we use newTagUnique to - -- generate a new unique from the case binder. - -- The case binder's unique will presumably - -- have the 'c' tag (generated by CoreToStg), - -- so we just change its tag to 'C' (for - -- 'case') to ensure it doesn't clash with - -- anything else. We can't use the unique - -- from the case binder, becaus e this is used - -- to hold the actual result closure (via the - -- call to bindNewToTemp) - in - do_enum_primop primop `thenFC` \ tag_amode -> - - -- Bind the default binder if necessary - -- (avoiding it avoids the assignment) - -- The deadness info is set by StgVarInfo - (if (isDeadBinder bndr) - then nopC - else bindNewToTemp bndr `thenFC` \ tmp_amode -> - absC (CAssign tmp_amode (tagToClosure tycon tag_amode)) - ) `thenC` - - -- Compile the alts - cgAlgAlts NoGC (getUnique bndr) - Nothing{-cc_slot-} False{-no semi-tagging-} - (AlgAlt tycon) alts `thenFC` \ tagged_alts -> - - -- Do the switch - absC (mkAlgAltsCSwitch tag_amode tagged_alts) - - other -> pprPanic "cgCase: case of primop has strange alt type" (ppr alt_type) - where - inline_primop = case op of - StgPrimOp primop -> not (primOpOutOfLine primop) - --StgFCallOp (CCall (CCallSpec _ _ PlayRisky)) _ -> True - -- unsafe foreign calls are "inline" - _otherwise -> False - + | not (primOpOutOfLine primop) + = cgInlinePrimOp primop args bndr alt_type live_in_alts alts \end{code} TODO: Case-of-case of primop can probably be done inline too (but @@ -240,6 +163,30 @@ maybe better to translate it out beforehand). See ghc/lib/misc/PackedString.lhs for examples where this crops up (with 4.02). +Special case #4: inline foreign calls: an unsafe foreign call can be done +right here, just like an inline primop. + +\begin{code} +cgCase (StgOpApp op@(StgFCallOp fcall _) args _) + live_in_whole_case live_in_alts bndr srt alt_type alts + | unsafe_foreign_call + = ASSERT( isSingleton alts ) + do -- *must* be an unboxed tuple alt. + -- exactly like the cgInlinePrimOp case for unboxed tuple alts.. + { res_tmps <- mapFCs bindNewToTemp non_void_res_ids + ; let res_hints = map (typeHint.idType) non_void_res_ids + ; cgForeignCall (zip res_tmps res_hints) fcall args live_in_alts + ; cgExpr rhs } + where + (_, res_ids, _, rhs) = head alts + non_void_res_ids = filter (nonVoidArg . idCgRep) res_ids + + unsafe_foreign_call + = case fcall of + CCall (CCallSpec _ _ s) -> not (playSafe s) + _other -> False +\end{code} + Special case: scrutinising a non-primitive variable. This can be done a little better than the general case, because we can reuse/trim the stack slot holding the variable (if it is in one). @@ -247,8 +194,8 @@ we can reuse/trim the stack slot holding the variable (if it is in one). \begin{code} cgCase (StgApp fun args) live_in_whole_case live_in_alts bndr srt alt_type alts - = getCAddrModeAndInfo fun `thenFC` \ (fun', fun_amode, lf_info) -> - getArgAmodes args `thenFC` \ arg_amodes -> + = do { fun_info <- getCgIdInfo fun + ; arg_amodes <- getArgAmodes args -- Nuking dead bindings *before* calculating the saves is the -- value-add here. We might end up freeing up some slots currently @@ -256,19 +203,18 @@ cgCase (StgApp fun args) -- NOTE: we need to look up the variables used in the call before -- doing this, because some of them may not be in the environment -- afterward. - nukeDeadBindings live_in_alts `thenC` - saveVolatileVarsAndRegs live_in_alts - `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) -> - - forkEval alts_eob_info - ( allocStackTop retPrimRepSize - `thenFC` \_ -> nopC ) - ( deAllocStackTop retPrimRepSize `thenFC` \_ -> - cgEvalAlts maybe_cc_slot bndr srt alt_type alts ) - `thenFC` \ scrut_eob_info -> - - setEndOfBlockInfo (maybeReserveSeqFrame alt_type scrut_eob_info) $ - performTailCall fun' fun_amode lf_info arg_amodes save_assts + ; nukeDeadBindings live_in_alts + ; (save_assts, alts_eob_info, maybe_cc_slot) + <- saveVolatileVarsAndRegs live_in_alts + + ; scrut_eob_info + <- forkEval alts_eob_info + (allocStackTop retAddrSizeW >> nopC) + (do { deAllocStackTop retAddrSizeW + ; cgEvalAlts maybe_cc_slot bndr srt alt_type alts }) + + ; setEndOfBlockInfo (maybeReserveSeqFrame alt_type scrut_eob_info) + (performTailCall fun_info arg_amodes save_assts) } \end{code} Note about return addresses: we *always* push a return address, even @@ -286,26 +232,27 @@ Finally, here is the general case. \begin{code} cgCase expr live_in_whole_case live_in_alts bndr srt alt_type alts - = -- Figure out what volatile variables to save - nukeDeadBindings live_in_whole_case `thenC` + = do { -- Figure out what volatile variables to save + nukeDeadBindings live_in_whole_case - saveVolatileVarsAndRegs live_in_alts - `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) -> - - -- Save those variables right now! - absC save_assts `thenC` - - -- generate code for the alts - forkEval alts_eob_info - (nukeDeadBindings live_in_alts `thenC` - allocStackTop retPrimRepSize -- space for retn address - `thenFC` \_ -> nopC - ) - (deAllocStackTop retPrimRepSize `thenFC` \_ -> - cgEvalAlts maybe_cc_slot bndr srt alt_type alts) `thenFC` \ scrut_eob_info -> - - setEndOfBlockInfo (maybeReserveSeqFrame alt_type scrut_eob_info) $ - cgExpr expr + ; (save_assts, alts_eob_info, maybe_cc_slot) + <- saveVolatileVarsAndRegs live_in_alts + + -- Save those variables right now! + ; emitStmts save_assts + + -- generate code for the alts + ; scrut_eob_info + <- forkEval alts_eob_info + (do { nukeDeadBindings live_in_alts + ; allocStackTop retAddrSizeW -- space for retn address + ; nopC }) + (do { deAllocStackTop retAddrSizeW + ; cgEvalAlts maybe_cc_slot bndr srt alt_type alts }) + + ; setEndOfBlockInfo (maybeReserveSeqFrame alt_type scrut_eob_info) + (cgExpr expr) + } \end{code} There's a lot of machinery going on behind the scenes to manage the @@ -329,25 +276,93 @@ because we don't reserve it until just before the eval. TODO!! Problem: however, we have to save the current cost centre stack somewhere, because at the eval point the current CCS might be -different. So we pick a free stack slot and save CCCS in it. The -problem with this is that this slot isn't recorded as free/unboxed in -the environment, so a case expression in the scrutinee will have the -wrong bitmap attached. Fortunately we don't ever seem to see -case-of-case at the back end. One solution might be to shift the -saved CCS to the correct place in the activation record just before -the jump. - --SDM - -(one consequence of the above is that activation records on the stack -don't follow the layout of closures when we're profiling. The CCS -could be anywhere within the record). +different. So we pick a free stack slot and save CCCS in it. One +consequence of this is that activation records on the stack don't +follow the layout of closures when we're profiling. The CCS could be +anywhere within the record). \begin{code} -maybeReserveSeqFrame PolyAlt (EndOfBlockInfo args_sp (CaseAlts amode stuff _)) - = EndOfBlockInfo (args_sp + retPrimRepSize) (CaseAlts amode stuff True) +maybeReserveSeqFrame PolyAlt (EndOfBlockInfo args_sp (CaseAlts amode stuff bndr _)) + = EndOfBlockInfo (args_sp + retAddrSizeW) (CaseAlts amode stuff bndr True) maybeReserveSeqFrame other scrut_eob_info = scrut_eob_info \end{code} + +%************************************************************************ +%* * + Inline primops +%* * +%************************************************************************ + +\begin{code} +cgInlinePrimOp primop args bndr (PrimAlt tycon) live_in_alts alts + | isVoidArg (idCgRep bndr) + = ASSERT( con == DEFAULT && isSingleton alts && null bs ) + do { -- VOID RESULT; just sequencing, + -- so get in there and do it + cgPrimOp [] primop args live_in_alts + ; cgExpr rhs } + where + (con,bs,_,rhs) = head alts + +cgInlinePrimOp primop args bndr (PrimAlt tycon) live_in_alts alts + = do { -- PRIMITIVE ALTS, with non-void result + tmp_reg <- bindNewToTemp bndr + ; cgPrimOp [tmp_reg] primop args live_in_alts + ; cgPrimAlts NoGC (PrimAlt tycon) tmp_reg alts } + +cgInlinePrimOp primop args bndr (UbxTupAlt tycon) live_in_alts alts + = ASSERT( isSingleton alts ) + do { -- UNBOXED TUPLE ALTS + -- No heap check, no yield, just get in there and do it. + -- NB: the case binder isn't bound to anything; + -- it has a unboxed tuple type + + res_tmps <- mapFCs bindNewToTemp non_void_res_ids + ; cgPrimOp res_tmps primop args live_in_alts + ; cgExpr rhs } + where + (_, res_ids, _, rhs) = head alts + non_void_res_ids = filter (nonVoidArg . idCgRep) res_ids + +cgInlinePrimOp primop args bndr (AlgAlt tycon) live_in_alts alts + = do { -- ENUMERATION TYPE RETURN + -- Typical: case a ># b of { True -> ..; False -> .. } + -- The primop itself returns an index into the table of + -- closures for the enumeration type. + tag_amode <- ASSERT( isEnumerationTyCon tycon ) + do_enum_primop primop + + -- Bind the default binder if necessary + -- (avoiding it avoids the assignment) + -- The deadness info is set by StgVarInfo + ; whenC (not (isDeadBinder bndr)) + (do { tmp_reg <- bindNewToTemp bndr + ; stmtC (CmmAssign tmp_reg (tagToClosure tycon tag_amode)) }) + + -- Compile the alts + ; (branches, mb_deflt) <- cgAlgAlts NoGC Nothing{-cc_slot-} + (AlgAlt tycon) alts + + -- Do the switch + ; emitSwitch tag_amode branches mb_deflt 0 (tyConFamilySize tycon - 1) + } + where + + do_enum_primop :: PrimOp -> FCode CmmExpr -- Returns amode for result + do_enum_primop TagToEnumOp -- No code! + | [arg] <- args = do + (_,e) <- getArgAmode arg + return e + do_enum_primop primop + = do tmp <- newTemp wordRep + cgPrimOp [tmp] primop args live_in_alts + returnFC (CmmReg tmp) + +cgInlinePrimOp primop arg_amodes bndr PolyAlt live_in_alts alts + = pprPanic "cgCase: case of primop has polymorphic type" (ppr bndr) +\end{code} + %************************************************************************ %* * \subsection[CgCase-alts]{Alternatives} @@ -368,6 +383,21 @@ cgEvalAlts :: Maybe VirtualSpOffset -- Offset of cost-centre to be restored, if -- to be a label so that we can duplicate it -- without risk of duplicating code +cgEvalAlts cc_slot bndr srt alt_type@(PrimAlt tycon) alts + = do { let rep = tyConCgRep tycon + reg = dataReturnConvPrim rep -- Bottom for voidRep + + ; abs_c <- forkProc $ do + { -- Bind the case binder, except if it's void + -- (reg is bottom in that case) + whenC (nonVoidArg rep) $ + bindNewToReg bndr reg (mkLFArgument bndr) + ; restoreCurrentCostCentre cc_slot True + ; cgPrimAlts GCMayHappen alt_type reg alts } + + ; lbl <- emitDirectReturnTarget (idName bndr) abs_c srt + ; returnFC (CaseAlts lbl Nothing bndr False) } + cgEvalAlts cc_slot bndr srt (UbxTupAlt _) [(con,args,_,rhs)] = -- Unboxed tuple case -- By now, the simplifier should have have turned it @@ -376,38 +406,24 @@ cgEvalAlts cc_slot bndr srt (UbxTupAlt _) [(con,args,_,rhs)] -- case e of DEFAULT -> e ASSERT2( case con of { DataAlt _ -> True; other -> False }, text "cgEvalAlts: dodgy case of unboxed tuple type" ) - - forkAbsC ( -- forkAbsC for the RHS, so that the envt is - -- not changed for the mkRetDirect call - bindUnboxedTupleComponents args `thenFC` \ (live_regs, ptrs, nptrs, _) -> - -- restore the CC *after* binding the tuple components, so that we - -- get the stack offset of the saved CC right. - restoreCurrentCostCentre cc_slot True `thenC` - -- Generate a heap check if necessary - unbxTupleHeapCheck live_regs ptrs nptrs AbsCNop ( - -- And finally the code for the alternative - cgExpr rhs - )) `thenFC` \ abs_c -> - mkRetDirectTarget bndr abs_c srt `thenFC` \ lbl -> - returnFC (CaseAlts lbl Nothing False) - -cgEvalAlts cc_slot bndr srt alt_type@(PrimAlt tycon) alts - = forkAbsC ( -- forkAbsC for the RHS, so that the envt is - -- not changed for the mkRetDirect call - restoreCurrentCostCentre cc_slot True `thenC` - bindNewToReg bndr reg (mkLFArgument bndr) `thenC` - cgPrimAlts GCMayHappen (CReg reg) alts alt_type - ) `thenFC` \ abs_c -> - mkRetDirectTarget bndr abs_c srt `thenFC` \ lbl -> - returnFC (CaseAlts lbl Nothing False) - where - reg = dataReturnConvPrim kind - kind = tyConPrimRep tycon + do { -- forkAbsC for the RHS, so that the envt is + -- not changed for the emitDirectReturn call + abs_c <- forkProc $ do + { (live_regs, ptrs, nptrs, _) <- bindUnboxedTupleComponents args + -- Restore the CC *after* binding the tuple components, + -- so that we get the stack offset of the saved CC right. + ; restoreCurrentCostCentre cc_slot True + -- Generate a heap check if necessary + -- and finally the code for the alternative + ; unbxTupleHeapCheck live_regs ptrs nptrs noStmts + (cgExpr rhs) } + ; lbl <- emitDirectReturnTarget (idName bndr) abs_c srt + ; returnFC (CaseAlts lbl Nothing bndr False) } cgEvalAlts cc_slot bndr srt alt_type alts = -- Algebraic and polymorphic case - -- Bind the default binder - bindNewToReg bndr node (mkLFArgument bndr) `thenC` + do { -- Bind the default binder + bindNewToReg bndr nodeReg (mkLFArgument bndr) -- Generate sequel info for use downstream -- At the moment, we only do it if the type is vector-returnable. @@ -418,25 +434,16 @@ cgEvalAlts cc_slot bndr srt alt_type alts -- -- which is worse than having the alt code in the switch statement - let ret_conv = case alt_type of - AlgAlt tc -> ctrlReturnConvAlg tc - PolyAlt -> UnvectoredReturn 0 - - use_labelled_alts = case ret_conv of - VectoredReturn _ -> True - _ -> False - - semi_tagged_stuff = cgSemiTaggedAlts use_labelled_alts bndr alts - - in - cgAlgAlts GCMayHappen (getUnique bndr) - cc_slot use_labelled_alts - alt_type alts `thenFC` \ tagged_alt_absCs -> + ; (alts, mb_deflt) <- cgAlgAlts GCMayHappen cc_slot alt_type alts - mkRetVecTarget bndr tagged_alt_absCs - srt ret_conv `thenFC` \ return_vec -> + ; (lbl, branches) <- emitAlgReturnTarget (idName bndr) + alts mb_deflt srt ret_conv - returnFC (CaseAlts return_vec semi_tagged_stuff False) + ; returnFC (CaseAlts lbl branches bndr False) } + where + ret_conv = case alt_type of + AlgAlt tc -> ctrlReturnConvAlg tc + PolyAlt -> UnvectoredReturn 0 \end{code} @@ -462,94 +469,42 @@ are inlined alternatives. \begin{code} cgAlgAlts :: GCFlag - -> Unique -> Maybe VirtualSpOffset - -> Bool -- True <=> branches must be labelled - -- (used for semi-tagging) - -> AltType -- ** AlgAlt or PolyAlt only ** - -> [StgAlt] -- The alternatives - -> FCode [(AltCon, AbstractC)] -- The branches + -> AltType -- ** AlgAlt or PolyAlt only ** + -> [StgAlt] -- The alternatives + -> FCode ( [(ConTagZ, CgStmts)], -- The branches + Maybe CgStmts ) -- The default case + +cgAlgAlts gc_flag cc_slot alt_type alts + = do alts <- forkAlts [ cgAlgAlt gc_flag cc_slot alt_type alt | alt <- alts] + let + mb_deflt = case alts of -- DEFAULT is always first, if present + ((DEFAULT,blks) : _) -> Just blks + other -> Nothing + + branches = [(dataConTagZ con, blks) + | (DataAlt con, blks) <- alts] + -- in + return (branches, mb_deflt) -cgAlgAlts gc_flag uniq restore_cc must_label_branches alt_type alts - = forkAlts [ cgAlgAlt gc_flag uniq restore_cc must_label_branches alt_type alt - | alt <- alts] cgAlgAlt :: GCFlag - -> Unique -> Maybe VirtualSpOffset -> Bool -- turgid state - -> AltType -- ** AlgAlt or PolyAlt only ** + -> Maybe VirtualSpOffset -- Turgid state + -> AltType -- ** AlgAlt or PolyAlt only ** -> StgAlt - -> FCode (AltCon, AbstractC) - -cgAlgAlt gc_flag uniq cc_slot must_label_branch - alt_type (con, args, use_mask, rhs) - = getAbsC (bind_con_args con args `thenFC` \ _ -> - restoreCurrentCostCentre cc_slot True `thenC` - maybeAltHeapCheck gc_flag alt_type (cgExpr rhs) - ) `thenFC` \ abs_c -> - let - final_abs_c | must_label_branch = CCodeBlock lbl abs_c - | otherwise = abs_c - in - returnFC (con, final_abs_c) + -> FCode (AltCon, CgStmts) + +cgAlgAlt gc_flag cc_slot alt_type (con, args, use_mask, rhs) + = do { abs_c <- getCgStmts $ do + { bind_con_args con args + ; restoreCurrentCostCentre cc_slot True + ; maybeAltHeapCheck gc_flag alt_type (cgExpr rhs) } + ; return (con, abs_c) } where - lbl = case con of - DataAlt dc -> mkAltLabel uniq (dataConTag dc) - DEFAULT -> mkDefaultLabel uniq - other -> pprPanic "cgAlgAlt" (ppr con) - bind_con_args DEFAULT args = nopC bind_con_args (DataAlt dc) args = bindConArgs dc args \end{code} -%************************************************************************ -%* * -\subsection[CgCase-semi-tagged-alts]{The code to deal with sem-tagging} -%* * -%************************************************************************ - -Turgid-but-non-monadic code to conjure up the required info from -algebraic case alternatives for semi-tagging. - -\begin{code} -cgSemiTaggedAlts :: Bool -- True <=> use semitagging: each alt will be labelled - -> Id - -> [StgAlt] - -> SemiTaggingStuff - -cgSemiTaggedAlts False binder alts - = Nothing -cgSemiTaggedAlts True binder alts - = Just ([st_alt con args | (DataAlt con, args, _, _) <- alts], - case head alts of - (DEFAULT, _, _, _) -> Just st_deflt - other -> Nothing) - where - uniq = getUnique binder - - st_deflt = (binder, - (CCallProfCtrMacro FSLIT("RET_SEMI_BY_DEFAULT") [], -- ToDo: monadise? - mkDefaultLabel uniq)) - - st_alt con args -- Ha! Nothing to do; Node already points to the thing - = (con_tag, - (CCallProfCtrMacro FSLIT("RET_SEMI_IN_HEAP") -- ToDo: monadise? - [mkIntCLit (length args)], -- how big the thing in the heap is - join_label) - ) - where - con_tag = dataConTag con - join_label = mkAltLabel uniq con_tag - - -tagToClosure :: TyCon -> CAddrMode -> CAddrMode --- Primops returning an enumeration type (notably Bool) --- actually return an index into --- the table of closures for the enumeration type -tagToClosure tycon tag_amode - = CVal (CIndex closure_tbl tag_amode PtrRep) PtrRep - where - closure_tbl = CLbl (mkClosureTblLabel tycon) PtrRep -\end{code} %************************************************************************ %* * @@ -566,29 +521,31 @@ As usual, no binders in the alternatives are yet bound. \begin{code} cgPrimAlts :: GCFlag - -> CAddrMode -- Scrutinee + -> AltType -- Always PrimAlt, but passed to maybeAltHeapCheck + -> CmmReg -- Scrutinee -> [StgAlt] -- Alternatives - -> AltType -> Code +-- NB: cgPrimAlts emits code that does the case analysis. +-- It's often used in inline situations, rather than to genearte +-- a labelled return point. That's why its interface is a little +-- different to cgAlgAlts +-- -- INVARIANT: the default binder is already bound -cgPrimAlts gc_flag scrutinee alts alt_type - = forkAlts (map (cgPrimAlt gc_flag alt_type) alts) `thenFC` \ tagged_absCs -> - let - ((DEFAULT, deflt_absC) : others) = tagged_absCs -- There is always a default - alt_absCs = [(lit,rhs) | (LitAlt lit, rhs) <- others] - in - absC (CSwitch scrutinee alt_absCs deflt_absC) - -- CSwitch does sensible things with one or zero alternatives +cgPrimAlts gc_flag alt_type scrutinee alts + = do { tagged_absCs <- forkAlts (map (cgPrimAlt gc_flag alt_type) alts) + ; let ((DEFAULT, deflt_absC) : others) = tagged_absCs -- There is always a default + alt_absCs = [(lit,rhs) | (LitAlt lit, rhs) <- others] + ; emitLitSwitch (CmmReg scrutinee) alt_absCs deflt_absC } cgPrimAlt :: GCFlag -> AltType - -> StgAlt -- The alternative - -> FCode (AltCon, AbstractC) -- Its compiled form + -> StgAlt -- The alternative + -> FCode (AltCon, CgStmts) -- Its compiled form cgPrimAlt gc_flag alt_type (con, [], [], rhs) = ASSERT( case con of { DEFAULT -> True; LitAlt _ -> True; other -> False } ) - getAbsC (maybeAltHeapCheck gc_flag alt_type (cgExpr rhs)) `thenFC` \ abs_c -> - returnFC (con, abs_c) + do { abs_c <- getCgStmts (maybeAltHeapCheck gc_flag alt_type (cgExpr rhs)) + ; returnFC (con, abs_c) } \end{code} @@ -605,52 +562,42 @@ maybeAltHeapCheck -> Code -- Continuation -> Code maybeAltHeapCheck NoGC _ code = code -maybeAltHeapCheck GCMayHappen alt_type code - = -- HWL: maybe need yield here - -- yield [node] True -- XXX live regs wrong - altHeapCheck alt_type code +maybeAltHeapCheck GCMayHappen alt_type code = altHeapCheck alt_type code saveVolatileVarsAndRegs :: StgLiveVars -- Vars which should be made safe - -> FCode (AbstractC, -- Assignments to do the saves + -> FCode (CmmStmts, -- Assignments to do the saves EndOfBlockInfo, -- sequel for the alts Maybe VirtualSpOffset) -- Slot for current cost centre saveVolatileVarsAndRegs vars - = saveVolatileVars vars `thenFC` \ var_saves -> - saveCurrentCostCentre `thenFC` \ (maybe_cc_slot, cc_save) -> - getEndOfBlockInfo `thenFC` \ eob_info -> - returnFC (mkAbstractCs [var_saves, cc_save], - eob_info, - maybe_cc_slot) + = do { var_saves <- saveVolatileVars vars + ; (maybe_cc_slot, cc_save) <- saveCurrentCostCentre + ; eob_info <- getEndOfBlockInfo + ; returnFC (var_saves `plusStmts` cc_save, + eob_info, + maybe_cc_slot) } saveVolatileVars :: StgLiveVars -- Vars which should be made safe - -> FCode AbstractC -- Assignments to to the saves + -> FCode CmmStmts -- Assignments to to the saves saveVolatileVars vars - = save_em (varSetElems vars) + = do { stmts_s <- mapFCs save_it (varSetElems vars) + ; return (foldr plusStmts noStmts stmts_s) } where - save_em [] = returnFC AbsCNop - - save_em (var:vars) - = getCAddrModeIfVolatile var `thenFC` \ v -> - case v of - Nothing -> save_em vars -- Non-volatile, so carry on - - - Just vol_amode -> -- Aha! It's volatile - save_var var vol_amode `thenFC` \ abs_c -> - save_em vars `thenFC` \ abs_cs -> - returnFC (abs_c `mkAbsCStmts` abs_cs) + save_it var + = do { v <- getCAddrModeIfVolatile var + ; case v of + Nothing -> return noStmts -- Non-volatile + Just vol_amode -> save_var var vol_amode -- Aha! It's volatile + } save_var var vol_amode - = allocPrimStack (getPrimRepSize kind) `thenFC` \ slot -> - rebindToStack var slot `thenC` - getSpRelOffset slot `thenFC` \ sp_rel -> - returnFC (CAssign (CVal sp_rel kind) vol_amode) - where - kind = getAmodeRep vol_amode + = do { slot <- allocPrimStack (idCgRep var) + ; rebindToStack var slot + ; sp_rel <- getSpRelOffset slot + ; returnFC (oneStmt (CmmStore sp_rel vol_amode)) } \end{code} --------------------------------------------------------------------------- @@ -663,123 +610,24 @@ virtual offset of the location, to pass on to the alternatives, and \begin{code} saveCurrentCostCentre :: FCode (Maybe VirtualSpOffset, -- Where we decide to store it - AbstractC) -- Assignment to save it + CmmStmts) -- Assignment to save it saveCurrentCostCentre - = if not opt_SccProfilingOn then - returnFC (Nothing, AbsCNop) - else - allocPrimStack (getPrimRepSize CostCentreRep) `thenFC` \ slot -> - dataStackSlots [slot] `thenC` - getSpRelOffset slot `thenFC` \ sp_rel -> - returnFC (Just slot, - CAssign (CVal sp_rel CostCentreRep) (CReg CurCostCentre)) + | not opt_SccProfilingOn + = returnFC (Nothing, noStmts) + | otherwise + = do { slot <- allocPrimStack PtrArg + ; sp_rel <- getSpRelOffset slot + ; returnFC (Just slot, + oneStmt (CmmStore sp_rel curCCS)) } -- Sometimes we don't free the slot containing the cost centre after restoring it -- (see CgLetNoEscape.cgLetNoEscapeBody). restoreCurrentCostCentre :: Maybe VirtualSpOffset -> Bool -> Code restoreCurrentCostCentre Nothing _freeit = nopC restoreCurrentCostCentre (Just slot) freeit - = getSpRelOffset slot `thenFC` \ sp_rel -> - (if freeit then freeStackSlots [slot] else nopC) `thenC` - absC (CCallProfCCMacro FSLIT("RESTORE_CCCS") [CVal sp_rel CostCentreRep]) - -- we use the RESTORE_CCCS macro, rather than just - -- assigning into CurCostCentre, in case RESTORE_CCCS - -- has some sanity-checking in it. -\end{code} - -%************************************************************************ -%* * -\subsection[CgCase-return-vec]{Building a return vector} -%* * -%************************************************************************ - -Build a return vector, and return a suitable label addressing -mode for it. - -\begin{code} -mkRetDirectTarget :: Id -- Used for labelling only - -> AbstractC -- Return code - -> SRT -- Live CAFs in return code - -> FCode CAddrMode -- Emit the labelled return block, - -- and return its label -mkRetDirectTarget bndr abs_c srt - = buildContLivenessMask bndr `thenFC` \ liveness -> - getSRTInfo name srt `thenFC` \ srt_info -> - absC (CRetDirect uniq abs_c srt_info liveness) `thenC` - return lbl - where - name = idName bndr - uniq = getUnique name - lbl = CLbl (mkReturnInfoLabel uniq) RetRep + = do { sp_rel <- getSpRelOffset slot + ; whenC freeit (freeStackSlots [slot]) + ; stmtC (CmmStore curCCSAddr (CmmLoad sp_rel wordRep)) } \end{code} -\begin{code} -mkRetVecTarget :: Id -- Just for its unique - -> [(AltCon, AbstractC)] -- Branch codes - -> SRT -- Continuation's SRT - -> CtrlReturnConvention - -> FCode CAddrMode - -mkRetVecTarget bndr tagged_alt_absCs srt (UnvectoredReturn 0) - = ASSERT( null other_alts ) - mkRetDirectTarget bndr deflt_absC srt - where - ((DEFAULT, deflt_absC) : other_alts) = tagged_alt_absCs - -mkRetVecTarget bndr tagged_alt_absCs srt (UnvectoredReturn n) - = mkRetDirectTarget bndr switch_absC srt - where - -- Find the tag explicitly rather than using tag_reg for now. - -- on architectures with lots of regs the tag will be loaded - -- into tag_reg by the code doing the returning. - tag = CMacroExpr WordRep GET_TAG [CVal (nodeRel 0) DataPtrRep] - switch_absC = mkAlgAltsCSwitch tag tagged_alt_absCs - - -mkRetVecTarget bndr tagged_alt_absCs srt (VectoredReturn table_size) - = buildContLivenessMask bndr `thenFC` \ liveness -> - getSRTInfo name srt `thenFC` \ srt_info -> - let - ret_vector = CRetVector vtbl_lbl vector_table srt_info liveness - in - absC (mkAbstractCs alts_absCs `mkAbsCStmts` ret_vector) `thenC` - -- Alts come first, because we don't want to declare all the symbols - - return (CLbl vtbl_lbl DataPtrRep) - where - tags = [fIRST_TAG .. (table_size+fIRST_TAG-1)] - vector_table = map mk_vector_entry tags - alts_absCs = map snd (sortBy cmp tagged_alt_absCs) - -- The sort is unnecessary; just there for now - -- to make the new order the same as the old - (DEFAULT,_) `cmp` (DEFAULT,_) = EQ - (DEFAULT,_) `cmp` _ = GT - (DataAlt d1,_) `cmp` (DataAlt d2,_) = dataConTag d1 `compare` dataConTag d2 - (DataAlt d1,_) `cmp` (DEFAULT, _) = LT - -- Others impossible - - name = idName bndr - uniq = getUnique name - vtbl_lbl = mkVecTblLabel uniq - - deflt_lbl :: CAddrMode - deflt_lbl = case tagged_alt_absCs of - (DEFAULT, abs_c) : _ -> get_block_label abs_c - other -> mkIntCLit 0 - -- 'other' case: the simplifier might have eliminated a case - -- so we may have e.g. case xs of - -- [] -> e - -- In that situation the default should never be taken, - -- so we just use '0' (=> seg fault if used) - - mk_vector_entry :: ConTag -> CAddrMode - mk_vector_entry tag - = case [ absC | (DataAlt d, absC) <- tagged_alt_absCs, dataConTag d == tag ] of - -- The comprehension neatly, and correctly, ignores the DEFAULT - [] -> deflt_lbl - [abs_c] -> get_block_label abs_c - _ -> panic "mkReturnVector: too many" - - get_block_label (CCodeBlock lbl _) = CLbl lbl CodePtrRep -\end{code} diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs index 6e77dc7853..dc5e9eae35 100644 --- a/ghc/compiler/codeGen/CgClosure.lhs +++ b/ghc/compiler/codeGen/CgClosure.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgClosure.lhs,v 1.62 2003/11/17 14:23:31 simonmar Exp $ +% $Id: CgClosure.lhs,v 1.63 2004/08/13 13:05:54 simonmar Exp $ % \section[CgClosure]{Code generation for closures} @@ -13,6 +13,7 @@ with {\em closures} on the RHSs of let(rec)s. See also module CgClosure ( cgTopRhsClosure, cgStdRhsClosure, cgRhsClosure, + emitBlackHoleCode, ) where #include "HsVersions.h" @@ -21,37 +22,38 @@ import {-# SOURCE #-} CgExpr ( cgExpr ) import CgMonad import CgBindery -import CgUpdate ( pushUpdateFrame ) import CgHeapery -import CgStackery -import CgUsages +import CgStackery ( mkVirtStkOffsets, pushUpdateFrame, getVirtSp, + setRealAndVirtualSp ) +import CgProf ( chooseDynCostCentres, ldvEnter, enterCostCentre, + costCentreFrom ) +import CgTicky +import CgParallel ( granYield, granFetchAndReschedule ) +import CgInfoTbls ( emitClosureCodeAndInfoTable, getSRTInfo ) +import CgCallConv ( assignCallRegs, mkArgDescr ) +import CgUtils ( emitDataLits, addIdReps, cmmRegOffW, + emitRtsCallWithVols ) import ClosureInfo -- lots and lots of stuff - -import AbsCUtils ( getAmodeRep, mkAbstractCs ) -import AbsCSyn -import CLabel - +import SMRep ( CgRep, cgRepSizeW, argMachRep, fixedHdrSize, WordOff, + idCgRep ) +import MachOp ( MachHint(..) ) +import Cmm +import CmmUtils ( CmmStmts, mkStmts, oneStmt, plusStmts, noStmts, + mkLblExpr ) +import CLabel ( mkRtsDataLabel, mkClosureLabel, mkRednCountsLabel, + mkSlowEntryLabel, mkIndStaticInfoLabel ) import StgSyn -import CmdLineOpts ( opt_GranMacros, opt_SccProfilingOn, opt_DoTickyProfiling ) +import CmdLineOpts ( opt_DoTickyProfiling ) import CostCentre -import Id ( Id, idName, idType, idPrimRep ) -import Name ( Name, isInternalName ) +import Id ( Id, idName, idType ) +import Name ( Name ) import Module ( Module, pprModule ) import ListSetOps ( minusList ) -import PrimRep ( PrimRep(..), getPrimRepSize ) -import Util ( isIn, splitAtList ) -import CmdLineOpts ( opt_SccProfilingOn ) +import Util ( isIn, mapAccumL, zipWithEqual ) +import BasicTypes ( TopLevelFlag(..) ) +import Constants ( oFFSET_StgInd_indirectee, wORD_SIZE ) import Outputable import FastString - -import Name ( nameOccName ) -import OccName ( occNameFS ) - --- Turgid imports for showTypeCategory -import PrelNames -import TcType ( Type, isDictTy, tcSplitTyConApp_maybe, tcSplitFunTy_maybe ) -import TyCon ( isPrimTyCon, isTupleTyCon, isEnumerationTyCon, maybeTyConSingleCon ) -import Maybe \end{code} %******************************************************** @@ -68,45 +70,29 @@ cgTopRhsClosure :: Id -> CostCentreStack -- Optional cost centre annotation -> StgBinderInfo -> SRT + -> UpdateFlag -> [Id] -- Args -> StgExpr - -> LambdaFormInfo -> FCode (Id, CgIdInfo) -cgTopRhsClosure id ccs binder_info srt args body lf_info - = - let - name = idName id - in - -- LAY OUT THE OBJECT - getSRTInfo name srt `thenFC` \ srt_info -> - moduleName `thenFC` \ mod_name -> - let - name = idName id - descr = closureDescription mod_name name - closure_info = layOutStaticNoFVClosure id lf_info srt_info descr +cgTopRhsClosure id ccs binder_info srt upd_flag args body = do + { -- LAY OUT THE OBJECT + let name = idName id + ; lf_info <- mkClosureLFInfo id TopLevel [] upd_flag args + ; srt_info <- getSRTInfo name srt + ; mod_name <- moduleName + ; let descr = closureDescription mod_name name + closure_info = mkClosureInfo True id lf_info 0 0 srt_info descr closure_label = mkClosureLabel name - cg_id_info = stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info - in - - -- BUILD THE OBJECT (IF NECESSARY) - ( - ({- if staticClosureRequired name binder_info lf_info - then -} - absC (mkStaticClosure closure_label closure_info ccs [] True) - {- else - nopC -} - ) - `thenC` - - -- GENERATE THE INFO TABLE (IF NECESSARY) - forkClosureBody (closureCodeBody binder_info closure_info - ccs args body) + cg_id_info = stableIdInfo id (mkLblExpr closure_label) lf_info + closure_rep = mkStaticClosureFields closure_info ccs True [] - ) `thenC` - - returnFC (id, cg_id_info) + -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY) + ; emitDataLits closure_label closure_rep + ; forkClosureBody (closureCodeBody binder_info closure_info + ccs args body) + ; returnFC (id, cg_id_info) } \end{code} %******************************************************** @@ -129,29 +115,26 @@ cgStdRhsClosure -> [StgArg] -- payload -> FCode (Id, CgIdInfo) -cgStdRhsClosure binder cc binder_info fvs args body lf_info payload - -- AHA! A STANDARD-FORM THUNK - = ( - -- LAY OUT THE OBJECT - getArgAmodes payload `thenFC` \ amodes -> - moduleName `thenFC` \ mod_name -> - let - descr = closureDescription mod_name (idName binder) - - (closure_info, amodes_w_offsets) - = layOutDynClosure binder getAmodeRep amodes lf_info NoC_SRT descr - -- No SRT for a standard-form closure - - (use_cc, blame_cc) = chooseDynCostCentres cc args fvs body - in +cgStdRhsClosure bndr cc bndr_info fvs args body lf_info payload + = do -- AHA! A STANDARD-FORM THUNK + { -- LAY OUT THE OBJECT + amodes <- getArgAmodes payload + ; mod_name <- moduleName + ; let (tot_wds, ptr_wds, amodes_w_offsets) = mkVirtHeapOffsets amodes + + descr = closureDescription mod_name (idName bndr) + closure_info = mkClosureInfo False -- Not static + bndr lf_info tot_wds ptr_wds + NoC_SRT -- No SRT for a std-form closure + descr + + ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body -- BUILD THE OBJECT - allocDynClosure closure_info use_cc blame_cc amodes_w_offsets - ) - `thenFC` \ heap_offset -> + ; heap_offset <- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets -- RETURN - returnFC (binder, heapIdInfo binder heap_offset lf_info) + ; returnFC (bndr, heapIdInfo bndr heap_offset lf_info) } \end{code} Here's the general case. @@ -162,15 +145,13 @@ cgRhsClosure :: Id -> StgBinderInfo -> SRT -> [Id] -- Free vars + -> UpdateFlag -> [Id] -- Args -> StgExpr - -> LambdaFormInfo -> FCode (Id, CgIdInfo) -cgRhsClosure binder cc binder_info srt fvs args body lf_info - = ( - -- LAY OUT THE OBJECT - -- +cgRhsClosure bndr cc bndr_info srt fvs upd_flag args body = do + { -- LAY OUT THE OBJECT -- If the binder is itself a free variable, then don't store -- it in the closure. Instead, just bind it to Node on entry. -- NB we can be sure that Node will point to it, because we @@ -179,62 +160,63 @@ cgRhsClosure binder cc binder_info srt fvs args body lf_info -- stored in the closure itself, so it will make sure that -- Node points to it... let - is_elem = isIn "cgRhsClosure" - - binder_is_a_fv = binder `is_elem` fvs - reduced_fvs = if binder_is_a_fv - then fvs `minusList` [binder] - else fvs - - name = idName binder - in - - mapFCs getCAddrModeAndInfo reduced_fvs `thenFC` \ fvs_w_amodes_and_info -> - getSRTInfo name srt `thenFC` \ srt_info -> - moduleName `thenFC` \ mod_name -> - let - descr = closureDescription mod_name (idName binder) - - closure_info :: ClosureInfo - bind_details :: [((Id, CAddrMode, LambdaFormInfo), VirtualHeapOffset)] - - (closure_info, bind_details) - = layOutDynClosure binder get_kind - fvs_w_amodes_and_info lf_info srt_info descr - - bind_fv ((id, _, lf_info), offset) = bindNewToNode id offset lf_info - - amodes_w_offsets = [(amode,offset) | ((_,amode,_), offset) <- bind_details] - - get_kind (id, _, _) = idPrimRep id - in + name = idName bndr + is_elem = isIn "cgRhsClosure" + bndr_is_a_fv = bndr `is_elem` fvs + reduced_fvs | bndr_is_a_fv = fvs `minusList` [bndr] + | otherwise = fvs + + ; lf_info <- mkClosureLFInfo bndr NotTopLevel fvs upd_flag args + ; fv_infos <- mapFCs getCgIdInfo reduced_fvs + ; srt_info <- getSRTInfo name srt + ; mod_name <- moduleName + ; let bind_details :: [(CgIdInfo, VirtualHpOffset)] + (tot_wds, ptr_wds, bind_details) = mkVirtHeapOffsets (map add_rep fv_infos) + add_rep info = (cgIdInfoArgRep info, info) + + descr = closureDescription mod_name name + closure_info = mkClosureInfo False -- Not static + bndr lf_info tot_wds ptr_wds + srt_info descr -- BUILD ITS INFO TABLE AND CODE - forkClosureBody ( - -- Bind the fvs - mapCs bind_fv bind_details `thenC` + ; forkClosureBody (do + { -- Bind the fvs + let bind_fv (info, offset) + = bindNewToNode (cgIdInfoId info) offset (cgIdInfoLF info) + ; mapCs bind_fv bind_details -- Bind the binder itself, if it is a free var - (if binder_is_a_fv then - bindNewToReg binder node lf_info - else - nopC) `thenC` - + ; whenC bndr_is_a_fv (bindNewToReg bndr nodeReg lf_info) + -- Compile the body - closureCodeBody binder_info closure_info cc args body - ) `thenC` + ; closureCodeBody bndr_info closure_info cc args body }) -- BUILD THE OBJECT - let - (use_cc, blame_cc) = chooseDynCostCentres cc args fvs body - in - allocDynClosure closure_info use_cc blame_cc amodes_w_offsets - ) `thenFC` \ heap_offset -> + ; let + to_amode (info, offset) = do { amode <- idInfoToAmode info + ; return (amode, offset) } + ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body + ; amodes_w_offsets <- mapFCs to_amode bind_details + ; heap_offset <- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets -- RETURN - returnFC (binder, heapIdInfo binder heap_offset lf_info) + ; returnFC (bndr, heapIdInfo bndr heap_offset lf_info) } + + +mkClosureLFInfo :: Id -- The binder + -> TopLevelFlag -- True of top level + -> [Id] -- Free vars + -> UpdateFlag -- Update flag + -> [Id] -- Args + -> FCode LambdaFormInfo +mkClosureLFInfo bndr top fvs upd_flag args + | null args = return (mkLFThunk (idType bndr) top fvs upd_flag) + | otherwise = do { arg_descr <- mkArgDescr (idName bndr) args + ; return (mkLFReEntrant top fvs args arg_descr) } \end{code} + %************************************************************************ %* * \subsection[code-for-closures]{The code for closures} @@ -253,32 +235,23 @@ closureCodeBody :: StgBinderInfo There are two main cases for the code for closures. If there are {\em no arguments}, then the closure is a thunk, and not in normal form. So it should set up an update frame (if it is shared). +NB: Thunks cannot have a primitive type! \begin{code} -closureCodeBody binder_info closure_info cc [] body - = -- thunks cannot have a primitive type! - getAbsC body_code `thenFC` \ body_absC -> - - absC (CClosureInfoAndCode closure_info body_absC) - where - is_box = case body of { StgApp fun [] -> True; _ -> False } - - ticky_ent_lit = if (isStaticClosure closure_info) - then FSLIT("TICK_ENT_STATIC_THK") - else FSLIT("TICK_ENT_DYN_THK") - - body_code = profCtrC ticky_ent_lit [] `thenC` - -- node always points when profiling, so this is ok: - ldvEnter `thenC` - thunkWrapper closure_info ( - -- We only enter cc after setting up update so - -- that cc of enclosing scope will be recorded - -- in update frame CAF/DICT functions will be - -- subsumed by this enclosing cc - enterCostCentreCode closure_info cc IsThunk is_box `thenC` - cgExpr body - ) - +closureCodeBody binder_info cl_info cc [] body = do + { body_absC <- getCgStmts $ do + { tickyEnterThunk cl_info + ; ldvEnter (CmmReg nodeReg) -- NB: Node always points when profiling + ; thunkWrapper cl_info $ do + -- We only enter cc after setting up update so + -- that cc of enclosing scope will be recorded + -- in update frame CAF/DICT functions will be + -- subsumed by this enclosing cc + { enterCostCentre cl_info cc body + ; cgExpr body } + } + + ; emitClosureCodeAndInfoTable cl_info [] body_absC } \end{code} If there is /at least one argument/, then this closure is in @@ -289,105 +262,60 @@ argSatisfactionCheck (by calling fetchAndReschedule). There info if Node points to closure is available. -- HWL \begin{code} -closureCodeBody binder_info closure_info cc all_args body - = let arg_reps = map idPrimRep all_args in - - getEntryConvention name lf_info arg_reps `thenFC` \ entry_conv -> - - let - -- Arg mapping for the entry point; as many args as poss in - -- registers; the rest on the stack - -- arg_regs are the registers used for arg passing - -- stk_args are the args which are passed on the stack - -- - -- Args passed on the stack are not tagged. - -- - arg_regs = case entry_conv of - DirectEntry lbl arity regs -> regs - _ -> panic "closureCodeBody" - in - - -- If this function doesn't have a specialised ArgDescr, we need - -- to generate the function's arg bitmap, slow-entry code, and - -- register-save code for the heap-check failure - -- - (case closureFunInfo closure_info of - Just (_, ArgGen slow_lbl liveness) -> - absC (maybeLargeBitmap liveness) `thenC` - absC (mkSlowEntryCode name slow_lbl arg_regs arg_reps) `thenC` - returnFC (mkRegSaveCode arg_regs arg_reps) - - other -> returnFC AbsCNop - ) - `thenFC` \ reg_save_code -> - - -- get the current virtual Sp (it might not be zero, eg. if we're - -- compiling a let-no-escape). - getVirtSp `thenFC` \vSp -> - - let - (reg_args, stk_args) = splitAtList arg_regs all_args - - (sp_stk_args, stk_offsets) - = mkVirtStkOffsets vSp idPrimRep stk_args - - entry_code = do - mod_name <- moduleName - profCtrC FSLIT("TICK_CTR") [ - CLbl ticky_ctr_label DataPtrRep, - mkCString (mkFastString (ppr_for_ticky_name mod_name name)), - mkIntCLit stg_arity, -- total # of args - mkIntCLit sp_stk_args, -- # passed on stk - mkCString (mkFastString (map (showTypeCategory . idType) all_args)) - ] - let prof = - profCtrC ticky_ent_lit [ - CLbl ticky_ctr_label DataPtrRep - ] - - -- Bind args to regs/stack as appropriate, and - -- record expected position of sps. - bindArgsToRegs reg_args arg_regs - mapCs bindNewToStack stk_offsets - setRealAndVirtualSp sp_stk_args - - -- Enter the closures cc, if required - enterCostCentreCode closure_info cc IsFunction False - - -- Do the business - funWrapper closure_info arg_regs reg_save_code - (prof >> cgExpr body) - in - - setTickyCtrLabel ticky_ctr_label ( - - forkAbsC entry_code `thenFC` \ entry_abs_c -> - moduleName `thenFC` \ mod_name -> - - -- Now construct the info table - absC (CClosureInfoAndCode closure_info entry_abs_c) - ) - where - ticky_ctr_label = mkRednCountsLabel name - - ticky_ent_lit = - if (isStaticClosure closure_info) - then FSLIT("TICK_ENT_STATIC_FUN_DIRECT") - else FSLIT("TICK_ENT_DYN_FUN_DIRECT") - - stg_arity = length all_args - lf_info = closureLFInfo closure_info - - -- Manufacture labels - name = closureName closure_info - - --- When printing the name of a thing in a ticky file, we want to --- give the module name even for *local* things. We print --- just "x (M)" rather that "M.x" to distinguish them from the global kind. -ppr_for_ticky_name mod_name name - | isInternalName name = showSDocDebug (ppr name <+> (parens (ppr mod_name))) - | otherwise = showSDocDebug (ppr name) +closureCodeBody binder_info cl_info cc args body = do + { -- Get the current virtual Sp (it might not be zero, + -- eg. if we're compiling a let-no-escape). + vSp <- getVirtSp + ; let (reg_args, other_args) = assignCallRegs (addIdReps args) + (sp_top, stk_args) = mkVirtStkOffsets vSp other_args + + -- Allocate the global ticky counter + ; let ticky_ctr_lbl = mkRednCountsLabel (closureName cl_info) + ; emitTickyCounter cl_info args sp_top + + -- ...and establish the ticky-counter + -- label for this block + ; setTickyCtrLabel ticky_ctr_lbl $ do + + -- Emit the slow-entry code + { reg_save_code <- mkSlowEntryCode cl_info reg_args + + -- Emit the main entry code + ; blks <- forkProc $ + mkFunEntryCode cl_info cc reg_args stk_args + sp_top reg_save_code body + ; emitClosureCodeAndInfoTable cl_info [] blks + }} + + + +mkFunEntryCode :: ClosureInfo + -> CostCentreStack + -> [(Id,GlobalReg)] -- Args in regs + -> [(Id,VirtualSpOffset)] -- Args on stack + -> VirtualSpOffset -- Last allocated word on stack + -> CmmStmts -- Register-save code in case of GC + -> StgExpr + -> Code +-- The main entry code for the closure +mkFunEntryCode cl_info cc reg_args stk_args sp_top reg_save_code body = do + { -- Bind args to regs/stack as appropriate, + -- and record expected position of sps + ; bindArgsToRegs reg_args + ; bindArgsToStack stk_args + ; setRealAndVirtualSp sp_top + + -- Enter the cost-centre, if required + -- ToDo: It's not clear why this is outside the funWrapper, + -- but the tickyEnterFun is inside. Perhaps we can put + -- them together? + ; enterCostCentre cl_info cc body + + -- Do the business + ; funWrapper cl_info reg_args reg_save_code $ do + { tickyEnterFun cl_info + ; cgExpr body } + } \end{code} The "slow entry" code for a function. This entry point takes its @@ -402,84 +330,45 @@ The slow entry point is used in two places: (b) returning from a heap-check failure \begin{code} -mkSlowEntryCode :: Name -> CLabel -> [MagicId] -> [PrimRep] -> AbstractC -mkSlowEntryCode name lbl regs reps - = CCodeBlock lbl ( - mkAbstractCs [assts, stk_adj, jump] - ) +mkSlowEntryCode :: ClosureInfo -> [(Id,GlobalReg)] -> FCode CmmStmts +-- If this function doesn't have a specialised ArgDescr, we need +-- to generate the function's arg bitmap, slow-entry code, and +-- register-save code for the heap-check failure +-- Here, we emit the slow-entry code, and +-- return the register-save assignments +mkSlowEntryCode cl_info reg_args + | Just (_, ArgGen _) <- closureFunInfo cl_info + = do { emitSimpleProc slow_lbl (emitStmts load_stmts) + ; return save_stmts } + | otherwise = return noStmts where - stk_offsets = scanl (\off rep -> off - getPrimRepSize rep) 0 reps - - assts = mkAbstractCs (zipWith3 mk_asst reps regs stk_offsets) - mk_asst rep reg offset = CAssign (CReg reg) (CVal (spRel 0 offset) rep) - - stk_adj = CAssign (CReg Sp) (CAddr (spRel 0 stk_final_offset)) - stk_final_offset = head (drop (length regs) stk_offsets) - - jump = CJump (CLbl (mkEntryLabel name) CodePtrRep) - -mkRegSaveCode :: [MagicId] -> [PrimRep] -> AbstractC -mkRegSaveCode regs reps - = mkAbstractCs [stk_adj, assts] - where - stk_adj = CAssign (CReg Sp) (CAddr (spRel 0 (negate stk_final_offset))) - - stk_final_offset = head (drop (length regs) stk_offsets) - stk_offsets = scanl (\off rep -> off - getPrimRepSize rep) 0 reps - - assts = mkAbstractCs (zipWith3 mk_asst reps regs stk_offsets) - mk_asst rep reg offset = CAssign (CVal (spRel 0 offset) rep) (CReg reg) + name = closureName cl_info + slow_lbl = mkSlowEntryLabel name + + load_stmts = mkStmts load_assts `plusStmts` mkStmts [stk_adj_pop, jump_to_entry] + save_stmts = oneStmt stk_adj_push `plusStmts` mkStmts save_assts + + reps_w_regs :: [(CgRep,GlobalReg)] + reps_w_regs = [(idCgRep id, reg) | (id,reg) <- reverse reg_args] + (final_stk_offset, stk_offsets) + = mapAccumL (\off (rep,_) -> (off + cgRepSizeW rep, off)) + 0 reps_w_regs + + load_assts = zipWithEqual "mk_load" mk_load reps_w_regs stk_offsets + mk_load (rep,reg) offset = CmmAssign (CmmGlobal reg) + (CmmLoad (cmmRegOffW spReg offset) + (argMachRep rep)) + + save_assts = zipWithEqual "mk_save" mk_save reps_w_regs stk_offsets + mk_save (rep,reg) offset = ASSERT( argMachRep rep == globalRegRep reg ) + CmmStore (cmmRegOffW spReg offset) + (CmmReg (CmmGlobal reg)) + + stk_adj_pop = CmmAssign spReg (cmmRegOffW spReg final_stk_offset) + stk_adj_push = CmmAssign spReg (cmmRegOffW spReg (- final_stk_offset)) + jump_to_entry = CmmJump (mkLblExpr (enterIdLabel name)) [] \end{code} -For lexically scoped profiling we have to load the cost centre from -the closure entered, if the costs are not supposed to be inherited. -This is done immediately on entering the fast entry point. - -Load current cost centre from closure, if not inherited. -Node is guaranteed to point to it, if profiling and not inherited. - -\begin{code} -data IsThunk = IsThunk | IsFunction -- Bool-like, local --- #ifdef DEBUG - deriving Eq --- #endif - -enterCostCentreCode - :: ClosureInfo -> CostCentreStack - -> IsThunk - -> Bool -- is_box: this closure is a special box introduced by SCCfinal - -> Code - -enterCostCentreCode closure_info ccs is_thunk is_box - = if not opt_SccProfilingOn then - nopC - else - ASSERT2(not (noCCSAttached ccs), ppr (closureName closure_info) <+> ppr ccs) - - if isSubsumedCCS ccs then - ASSERT(isToplevClosure closure_info) - ASSERT(is_thunk == IsFunction) - costCentresC FSLIT("ENTER_CCS_FSUB") [] - - else if isDerivedFromCurrentCCS ccs then - if re_entrant && not is_box - then costCentresC FSLIT("ENTER_CCS_FCL") [CReg node] - else costCentresC FSLIT("ENTER_CCS_TCL") [CReg node] - - else if isCafCCS ccs then - ASSERT(isToplevClosure closure_info) - ASSERT(is_thunk == IsThunk) - -- might be a PAP, in which case we want to subsume costs - if re_entrant - then costCentresC FSLIT("ENTER_CCS_FSUB") [] - else costCentresC FSLIT("ENTER_CCS_CAF") c_ccs - - else panic "enterCostCentreCode" - - where - c_ccs = [mkCCostCentreStack ccs] - re_entrant = closureReEntrant closure_info -\end{code} %************************************************************************ %* * @@ -489,62 +378,42 @@ enterCostCentreCode closure_info ccs is_thunk is_box \begin{code} thunkWrapper:: ClosureInfo -> Code -> Code -thunkWrapper closure_info thunk_code - = -- Stack and heap overflow checks - nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points -> +thunkWrapper closure_info thunk_code = do + { let node_points = nodeMustPointToIt (closureLFInfo closure_info) -- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node -- (we prefer fetchAndReschedule-style context switches to yield ones) - (if opt_GranMacros - then if node_points - then fetchAndReschedule [] node_points - else yield [] node_points - else absC AbsCNop) `thenC` - - let closure_lbl - | node_points = Nothing - | otherwise = Just (closureLabelFromCI closure_info) - in - - -- stack and/or heap checks - thunkChecks closure_lbl ( - - -- Overwrite with black hole if necessary - blackHoleIt closure_info node_points `thenC` - - setupUpdate closure_info ( -- setupUpdate *encloses* the rest - - -- Finally, do the business - thunk_code - )) + ; if node_points + then granFetchAndReschedule [] node_points + else granYield [] node_points + + -- Stack and/or heap checks + ; thunkEntryChecks closure_info $ do + { -- Overwrite with black hole if necessary + whenC (blackHoleOnEntry closure_info && node_points) + (blackHoleIt closure_info) + ; setupUpdate closure_info thunk_code } + -- setupUpdate *encloses* the thunk_code + } funWrapper :: ClosureInfo -- Closure whose code body this is - -> [MagicId] -- List of argument registers (if any) - -> AbstractC -- reg saves for the heap check failure + -> [(Id,GlobalReg)] -- List of argument registers (if any) + -> CmmStmts -- reg saves for the heap check failure -> Code -- Body of function being compiled -> Code -funWrapper closure_info arg_regs reg_save_code fun_body - = -- Stack overflow check - nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points -> - - -- enter for Ldv profiling - (if node_points then ldvEnter else nopC) `thenC` +funWrapper closure_info arg_regs reg_save_code fun_body = do + { let node_points = nodeMustPointToIt (closureLFInfo closure_info) - (if opt_GranMacros - then yield arg_regs node_points - else absC AbsCNop) `thenC` + -- Enter for Ldv profiling + ; whenC node_points (ldvEnter (CmmReg nodeReg)) - let closure_lbl - | node_points = Nothing - | otherwise = Just (closureLabelFromCI closure_info) - in + -- GranSim yeild poin + ; granYield arg_regs node_points - -- heap and/or stack checks - funEntryChecks closure_lbl reg_save_code ( - - -- Finally, do the business - fun_body - ) + -- Heap and/or stack checks wrap the function body + ; funEntryChecks closure_info reg_save_code + fun_body + } \end{code} @@ -556,78 +425,150 @@ funWrapper closure_info arg_regs reg_save_code fun_body \begin{code} -blackHoleIt :: ClosureInfo -> Bool -> Code -- Only called for closures with no args - -blackHoleIt closure_info node_points - = if blackHoleOnEntry closure_info && node_points - then - let - info_label = infoTableLabelFromCI closure_info - args = [ CLbl info_label DataPtrRep ] - in - absC (if closureSingleEntry(closure_info) then - CMacroStmt UPD_BH_SINGLE_ENTRY args - else - CMacroStmt UPD_BH_UPDATABLE args) - else +blackHoleIt :: ClosureInfo -> Code +-- Only called for closures with no args +-- Node points to the closure +blackHoleIt closure_info = emitBlackHoleCode (closureSingleEntry closure_info) + +emitBlackHoleCode :: Bool -> Code +emitBlackHoleCode is_single_entry + | eager_blackholing = do + tickyBlackHole (not is_single_entry) + stmtC (CmmStore (CmmReg nodeReg) (CmmLit (CmmLabel bh_lbl))) + | otherwise = nopC + where + bh_lbl | is_single_entry = mkRtsDataLabel SLIT("stg_SE_BLACKHOLE_info") + | otherwise = mkRtsDataLabel SLIT("stg_BLACKHOLE_info") + + -- If we wanted to do eager blackholing with slop filling, + -- we'd need to do it at the *end* of a basic block, otherwise + -- we overwrite the free variables in the thunk that we still + -- need. We have a patch for this from Andy Cheadle, but not + -- incorporated yet. --SDM [6/2004] + -- + -- Profiling needs slop filling (to support LDV profiling), so + -- currently eager blackholing doesn't work with profiling. + -- + -- TICKY_TICKY needs EAGER_BLACKHOLING to verify no double-entries of + -- single-entry thunks. + eager_blackholing + | opt_DoTickyProfiling = True + | otherwise = False + \end{code} \begin{code} setupUpdate :: ClosureInfo -> Code -> Code -- Only called for closures with no args -- Nota Bene: this function does not change Node (even if it's a CAF), -- so that the cost centre in the original closure can still be - -- extracted by a subsequent ENTER_CC_TCL - --- I've tidied up the code for this function, but it should still do the same as --- it did before (modulo ticky stuff). KSW 1999-04. + -- extracted by a subsequent enterCostCentre setupUpdate closure_info code - = if closureReEntrant closure_info - then - code - else - case (closureUpdReqd closure_info, isStaticClosure closure_info) of - (False,False) -> profCtrC FSLIT("TICK_UPDF_OMITTED") [] `thenC` - code - (False,True ) -> (if opt_DoTickyProfiling - then - -- blackhole the SE CAF - link_caf seCafBlackHoleClosureInfo `thenFC` \ _ -> nopC - else - nopC) `thenC` - profCtrC FSLIT("TICK_UPD_CAF_BH_SINGLE_ENTRY") [mkCString cl_name] `thenC` - profCtrC FSLIT("TICK_UPDF_OMITTED") [] `thenC` - code - (True ,False) -> pushUpdateFrame (CReg node) code - (True ,True ) -> -- blackhole the (updatable) CAF: - link_caf cafBlackHoleClosureInfo `thenFC` \ update_closure -> - profCtrC FSLIT("TICK_UPD_CAF_BH_UPDATABLE") [mkCString cl_name] `thenC` - pushUpdateFrame update_closure code - where - cl_name :: FastString - cl_name = (occNameFS . nameOccName . closureName) closure_info - - link_caf :: (ClosureInfo -> ClosureInfo) -- function yielding BH closure_info - -> FCode CAddrMode -- Returns amode for closure to be updated - link_caf bhCI - = -- To update a CAF we must allocate a black hole, link the CAF onto the - -- CAF list, then update the CAF to point to the fresh black hole. - -- This function returns the address of the black hole, so it can be - -- updated with the new value when available. - - -- Alloc black hole specifying CC_HDR(Node) as the cost centre - let - use_cc = CMacroExpr PtrRep CCS_HDR [nodeReg] - blame_cc = use_cc - in - allocDynClosure (bhCI closure_info) use_cc blame_cc [] `thenFC` \ heap_offset -> - getHpRelOffset heap_offset `thenFC` \ hp_rel -> - let amode = CAddr hp_rel - in - absC (CMacroStmt UPD_CAF [CReg node, amode]) `thenC` - returnFC amode + | closureReEntrant closure_info + = code + + | not (isStaticClosure closure_info) + = if closureUpdReqd closure_info + then do { tickyPushUpdateFrame; pushUpdateFrame (CmmReg nodeReg) code } + else do { tickyUpdateFrameOmitted; code } + + | otherwise -- A static closure + = do { tickyUpdateBhCaf closure_info + + ; if closureUpdReqd closure_info + then do -- Blackhole the (updatable) CAF: + { upd_closure <- link_caf closure_info True + ; pushUpdateFrame upd_closure code } + else do + { -- No update reqd, you'd think we don't need to + -- black-hole it. But when ticky-ticky is on, we + -- black-hole it regardless, to catch errors in which + -- an allegedly single-entry closure is entered twice + -- + -- We discard the pointer returned by link_caf, because + -- we don't push an update frame + whenC opt_DoTickyProfiling -- Blackhole even a SE CAF + (link_caf closure_info False >> nopC) + ; tickyUpdateFrameOmitted + ; code } + } + + +----------------------------------------------------------------------------- +-- Entering a CAF +-- +-- When a CAF is first entered, it creates a black hole in the heap, +-- and updates itself with an indirection to this new black hole. +-- +-- We update the CAF with an indirection to a newly-allocated black +-- hole in the heap. We also set the blocking queue on the newly +-- allocated black hole to be empty. +-- +-- Why do we make a black hole in the heap when we enter a CAF? +-- +-- - for a generational garbage collector, which needs a fast +-- test for whether an updatee is in an old generation or not +-- +-- - for the parallel system, which can implement updates more +-- easily if the updatee is always in the heap. (allegedly). +-- +-- When debugging, we maintain a separate CAF list so we can tell when +-- a CAF has been garbage collected. + +-- newCAF must be called before the itbl ptr is overwritten, since +-- newCAF records the old itbl ptr in order to do CAF reverting +-- (which Hugs needs to do in order that combined mode works right.) +-- + +-- ToDo [Feb 04] This entire link_caf nonsense could all be moved +-- into the "newCAF" RTS procedure, which we call anyway, including +-- the allocation of the black-hole indirection closure. +-- That way, code size would fall, the CAF-handling code would +-- be closer together, and the compiler wouldn't need to know +-- about off_indirectee etc. + +link_caf :: ClosureInfo + -> Bool -- True <=> updatable, False <=> single-entry + -> FCode CmmExpr -- Returns amode for closure to be updated +-- To update a CAF we must allocate a black hole, link the CAF onto the +-- CAF list, then update the CAF to point to the fresh black hole. +-- This function returns the address of the black hole, so it can be +-- updated with the new value when available. The reason for all of this +-- is that we only want to update dynamic heap objects, not static ones, +-- so that generational GC is easier. +link_caf cl_info is_upd = do + { -- Alloc black hole specifying CC_HDR(Node) as the cost centre + ; let use_cc = costCentreFrom (CmmReg nodeReg) + blame_cc = use_cc + ; hp_offset <- allocDynClosure bh_cl_info use_cc blame_cc [] + ; hp_rel <- getHpRelOffset hp_offset + + -- Call the RTS function newCAF to add the CAF to the CafList + -- so that the garbage collector can find them + -- This must be done *before* the info table pointer is overwritten, + -- because the old info table ptr is needed for reversion + ; emitRtsCallWithVols SLIT("newCAF") [(CmmReg nodeReg,PtrHint)] [node] + -- node is live, so save it. + + -- Overwrite the closure with a (static) indirection + -- to the newly-allocated black hole + ; stmtsC [ CmmStore (cmmRegOffW nodeReg off_indirectee) hp_rel + , CmmStore (CmmReg nodeReg) ind_static_info ] + + ; returnFC hp_rel } + where + bh_cl_info :: ClosureInfo + bh_cl_info | is_upd = cafBlackHoleClosureInfo cl_info + | otherwise = seCafBlackHoleClosureInfo cl_info + + ind_static_info :: CmmExpr + ind_static_info = mkLblExpr mkIndStaticInfoLabel + + off_indirectee :: WordOff + off_indirectee = fixedHdrSize + oFFSET_StgInd_indirectee*wORD_SIZE \end{code} + %************************************************************************ %* * \subsection[CgClosure-Description]{Profiling Closure Description.} @@ -635,99 +576,17 @@ setupUpdate closure_info code %************************************************************************ For "global" data constructors the description is simply occurrence -name of the data constructor itself (see \ref{CgConTbls-info-tables}). - -Otherwise it is determind by @closureDescription@ from the let -binding information. +name of the data constructor itself. Otherwise it is determined by +@closureDescription@ from the let binding information. \begin{code} closureDescription :: Module -- Module -> Name -- Id of closure binding -> String - -- Not called for StgRhsCon which have global info tables built in -- CgConTbls.lhs with a description generated from the data constructor - closureDescription mod_name name - = showSDoc ( - hcat [char '<', - pprModule mod_name, - char '.', - ppr name, - char '>']) + = showSDoc (hcat [char '<', pprModule mod_name, + char '.', ppr name, char '>']) \end{code} -\begin{code} -chooseDynCostCentres ccs args fvs body - = let - use_cc -- cost-centre we record in the object - = if currentOrSubsumedCCS ccs - then CReg CurCostCentre - else mkCCostCentreStack ccs - - blame_cc -- cost-centre on whom we blame the allocation - = case (args, fvs, body) of - ([], _, StgApp fun [{-no args-}]) - -> mkCCostCentreStack overheadCCS - _ -> use_cc - - -- if it's an utterly trivial RHS, then it must be - -- one introduced by boxHigherOrderArgs for profiling, - -- so we charge it to "OVERHEAD". - - -- This looks like a HACK to me --SDM - in - (use_cc, blame_cc) -\end{code} - - -\begin{code} -showTypeCategory :: Type -> Char - {- - {C,I,F,D} char, int, float, double - T tuple - S other single-constructor type - {c,i,f,d} unboxed ditto - t *unpacked* tuple - s *unpacked" single-cons... - - v void# - a primitive array - - E enumeration type - + dictionary, unless it's a ... - L List - > function - M other (multi-constructor) data-con type - . other type - - reserved for others to mark as "uninteresting" - -} -showTypeCategory ty - = if isDictTy ty - then '+' - else - case tcSplitTyConApp_maybe ty of - Nothing -> if isJust (tcSplitFunTy_maybe ty) - then '>' - else '.' - - Just (tycon, _) -> - let utc = getUnique tycon in - if utc == charDataConKey then 'C' - else if utc == intDataConKey then 'I' - else if utc == floatDataConKey then 'F' - else if utc == doubleDataConKey then 'D' - else if utc == smallIntegerDataConKey || - utc == largeIntegerDataConKey then 'J' - else if utc == charPrimTyConKey then 'c' - else if (utc == intPrimTyConKey || utc == wordPrimTyConKey - || utc == addrPrimTyConKey) then 'i' - else if utc == floatPrimTyConKey then 'f' - else if utc == doublePrimTyConKey then 'd' - else if isPrimTyCon tycon {- array, we hope -} then 'A' -- Bogus - else if isEnumerationTyCon tycon then 'E' - else if isTupleTyCon tycon then 'T' - else if isJust (maybeTyConSingleCon tycon) then 'S' - else if utc == listTyConKey then 'L' - else 'M' -- oh, well... -\end{code} diff --git a/ghc/compiler/codeGen/CgCon.lhs b/ghc/compiler/codeGen/CgCon.lhs index 4b8e8c2bac..3cd67e4294 100644 --- a/ghc/compiler/codeGen/CgCon.lhs +++ b/ghc/compiler/codeGen/CgCon.lhs @@ -11,49 +11,53 @@ with {\em constructors} on the RHSs of let(rec)s. See also module CgCon ( cgTopRhsCon, buildDynCon, bindConArgs, bindUnboxedTupleComponents, - cgReturnDataCon + cgReturnDataCon, + cgTyCon ) where #include "HsVersions.h" import CgMonad -import AbsCSyn import StgSyn -import AbsCUtils ( getAmodeRep ) import CgBindery ( getArgAmodes, bindNewToNode, - bindArgsToRegs, - idInfoToAmode, stableAmodeIdInfo, - heapIdInfo, CgIdInfo, bindNewToStack + bindArgsToRegs, idInfoToAmode, stableIdInfo, + heapIdInfo, CgIdInfo, bindArgsToStack ) -import CgStackery ( mkVirtStkOffsets, freeStackSlots ) -import CgUsages ( getRealSp, getVirtSp, setRealAndVirtualSp ) -import CgRetConv ( assignRegs ) +import CgStackery ( mkVirtStkOffsets, freeStackSlots, + getRealSp, getVirtSp, setRealAndVirtualSp ) +import CgUtils ( addIdReps, cmmLabelOffW, emitRODataLits, emitDataLits ) +import CgCallConv ( assignReturnRegs ) import Constants ( mAX_INTLIKE, mIN_INTLIKE, mAX_CHARLIKE, mIN_CHARLIKE ) -import CgHeapery ( allocDynClosure ) -import CgTailCall ( performReturn, mkStaticAlgReturnCode, - returnUnboxedTuple ) -import CLabel ( mkClosureLabel ) -import ClosureInfo ( mkConLFInfo, mkLFArgument, layOutDynConstr, - layOutStaticConstr, mkStaticClosure - ) +import CgHeapery ( allocDynClosure, layOutDynConstr, + layOutStaticConstr, mkStaticClosureFields ) +import CgTailCall ( performReturn, emitKnownConReturnCode, returnUnboxedTuple ) +import CgProf ( mkCCostCentreStack, ldvEnter, curCCS ) +import CgTicky +import CgInfoTbls ( emitClosureCodeAndInfoTable, dataConTagZ ) +import CLabel ( mkClosureLabel, mkRtsDataLabel, mkClosureTblLabel ) +import ClosureInfo ( mkConLFInfo, mkLFArgument ) +import CmmUtils ( mkLblExpr ) +import Cmm +import SMRep ( WordOff, CgRep, separateByPtrFollowness, + fixedHdrSize, typeCgRep ) import CostCentre ( currentOrSubsumedCCS, dontCareCCS, CostCentreStack, currentCCS ) -import DataCon ( DataCon, dataConTag, +import Constants ( mIN_INTLIKE, mAX_INTLIKE, mIN_CHARLIKE, mAX_CHARLIKE ) +import TyCon ( TyCon, tyConDataCons, isEnumerationTyCon, tyConName ) +import DataCon ( DataCon, dataConRepArgTys, isNullaryDataCon, isUnboxedTupleCon, dataConWorkId, dataConName, dataConRepArity ) -import Id ( Id, idName, idPrimRep, isDeadBinder ) -import Literal ( Literal(..) ) +import Id ( Id, idName, isDeadBinder ) +import Type ( Type ) import PrelInfo ( maybeCharLikeCon, maybeIntLikeCon ) -import PrimRep ( PrimRep(..), isFollowableRep ) -import Util import Outputable - -import List ( partition ) -import Char ( ord ) +import Util ( lengthIs ) +import ListSetOps ( assocMaybe ) \end{code} + %************************************************************************ %* * \subsection[toplevel-constructors]{Top-level constructors} @@ -68,34 +72,32 @@ cgTopRhsCon :: Id -- Name of thing bound to this RHS cgTopRhsCon id con args = ASSERT( not (isDllConApp con args) ) ASSERT( args `lengthIs` dataConRepArity con ) + do { -- LAY IT OUT + ; amodes <- getArgAmodes args + + ; let + name = idName id + lf_info = mkConLFInfo con + closure_label = mkClosureLabel name + caffy = any stgArgHasCafRefs args + (closure_info, amodes_w_offsets) = layOutStaticConstr con amodes + closure_rep = mkStaticClosureFields + closure_info + dontCareCCS -- Because it's static data + caffy -- Has CAF refs + payload + + payload = map get_lit amodes_w_offsets + get_lit (CmmLit lit, _offset) = lit + get_lit other = pprPanic "CgCon.get_lit" (ppr other) + -- NB1: amodes_w_offsets is sorted into ptrs first, then non-ptrs + -- NB2: all the amodes should be Lits! + + -- BUILD THE OBJECT + ; emitDataLits closure_label closure_rep - -- LAY IT OUT - getArgAmodes args `thenFC` \ amodes -> - - let - name = idName id - lf_info = mkConLFInfo con - closure_label = mkClosureLabel name - (closure_info, amodes_w_offsets) - = layOutStaticConstr con getAmodeRep amodes - caffy = any stgArgHasCafRefs args - in - - -- BUILD THE OBJECT - absC (mkStaticClosure - closure_label - closure_info - dontCareCCS -- because it's static data - (map fst amodes_w_offsets) -- Sorted into ptrs first, then nonptrs - caffy -- has CAF refs - ) `thenC` - -- NOTE: can't use idCafInfo instead of nonEmptySRT above, - -- because top-level constructors that were floated by - -- CorePrep don't have CafInfo attached. The SRT is more - -- reliable. - - -- RETURN - returnFC (id, stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info) + -- RETURN + ; returnFC (id, stableIdInfo id (mkLblExpr closure_label) lf_info) } \end{code} %************************************************************************ @@ -106,13 +108,13 @@ cgTopRhsCon id con args \subsection[code-for-constructors]{The code for constructors} \begin{code} -buildDynCon :: Id -- Name of the thing to which this constr will - -- be bound - -> CostCentreStack -- Where to grab cost centre from; - -- current CCS if currentOrSubsumedCCS - -> DataCon -- The data constructor - -> [CAddrMode] -- Its args - -> FCode CgIdInfo -- Return details about how to find it +buildDynCon :: Id -- Name of the thing to which this constr will + -- be bound + -> CostCentreStack -- Where to grab cost centre from; + -- current CCS if currentOrSubsumedCCS + -> DataCon -- The data constructor + -> [(CgRep,CmmExpr)] -- Its args + -> FCode CgIdInfo -- Return details about how to find it -- We used to pass a boolean indicating whether all the -- args were of size zero, so we could use a static @@ -135,9 +137,9 @@ at all. \begin{code} buildDynCon binder cc con [] - = returnFC (stableAmodeIdInfo binder - (CLbl (mkClosureLabel (dataConName con)) PtrRep) - (mkConLFInfo con)) + = returnFC (stableIdInfo binder + (mkLblExpr (mkClosureLabel (dataConName con))) + (mkConLFInfo con)) \end{code} The following three paragraphs about @Char@-like and @Int@-like @@ -163,36 +165,41 @@ Because of this, we use can safely return an addressing mode. \begin{code} buildDynCon binder cc con [arg_amode] - | maybeIntLikeCon con && in_range_int_lit arg_amode - = returnFC (stableAmodeIdInfo binder (CIntLike arg_amode) (mkConLFInfo con)) - where - in_range_int_lit (CLit (MachInt val)) = val <= mAX_INTLIKE && val >= mIN_INTLIKE - in_range_int_lit _other_amode = False + | maybeIntLikeCon con + , (_, CmmLit (CmmInt val _)) <- arg_amode + , let val_int = (fromIntegral val) :: Int + , val_int <= mAX_INTLIKE && val_int >= mIN_INTLIKE + = do { let intlike_lbl = mkRtsDataLabel SLIT("stg_INTLIKE_closure") + offsetW = (val_int - mIN_INTLIKE) * (fixedHdrSize + 1) + -- INTLIKE closures consist of a header and one word payload + intlike_amode = CmmLit (cmmLabelOffW intlike_lbl offsetW) + ; returnFC (stableIdInfo binder intlike_amode (mkConLFInfo con)) } buildDynCon binder cc con [arg_amode] - | maybeCharLikeCon con && in_range_char_lit arg_amode - = returnFC (stableAmodeIdInfo binder (CCharLike arg_amode) (mkConLFInfo con)) - where - in_range_char_lit (CLit (MachChar val)) = - ord val <= mAX_CHARLIKE && ord val >= mIN_CHARLIKE - in_range_char_lit _other_amode = False + | maybeCharLikeCon con + , (_, CmmLit (CmmInt val _)) <- arg_amode + , let val_int = (fromIntegral val) :: Int + , val_int <= mAX_CHARLIKE && val_int >= mIN_CHARLIKE + = do { let charlike_lbl = mkRtsDataLabel SLIT("stg_CHARLIKE_closure") + offsetW = (val_int - mIN_CHARLIKE) * (fixedHdrSize + 1) + -- CHARLIKE closures consist of a header and one word payload + charlike_amode = CmmLit (cmmLabelOffW charlike_lbl offsetW) + ; returnFC (stableIdInfo binder charlike_amode (mkConLFInfo con)) } \end{code} Now the general case. \begin{code} buildDynCon binder ccs con args - = allocDynClosure closure_info use_cc blame_cc amodes_w_offsets `thenFC` \ hp_off -> - returnFC (heapIdInfo binder hp_off lf_info) + = do { hp_off <- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets + ; returnFC (heapIdInfo binder hp_off lf_info) } where lf_info = mkConLFInfo con - - (closure_info, amodes_w_offsets) = layOutDynConstr con getAmodeRep args + (closure_info, amodes_w_offsets) = layOutDynConstr con args use_cc -- cost-centre to stick in the object - = if currentOrSubsumedCCS ccs - then CReg CurCostCentre - else mkCCostCentreStack ccs + | currentOrSubsumedCCS ccs = curCCS + | otherwise = CmmLit (mkCCostCentreStack ccs) blame_cc = use_cc -- cost-centre on which to blame the alloc (same) \end{code} @@ -211,16 +218,13 @@ binders $args$, assuming that we have just returned from a @case@ which found a $con$. \begin{code} -bindConArgs - :: DataCon -> [Id] -- Constructor and args - -> Code - +bindConArgs :: DataCon -> [Id] -> Code bindConArgs con args = ASSERT(not (isUnboxedTupleCon con)) mapCs bind_arg args_w_offsets where bind_arg (arg, offset) = bindNewToNode arg offset (mkLFArgument arg) - (_, args_w_offsets) = layOutDynConstr con idPrimRep args + (_, args_w_offsets) = layOutDynConstr con (addIdReps args) \end{code} Unboxed tuples are handled slightly differently - the object is @@ -228,56 +232,53 @@ returned in registers and on the stack instead of the heap. \begin{code} bindUnboxedTupleComponents - :: [Id] -- Aargs - -> FCode ([MagicId], -- Regs assigned - Int, -- Number of pointer stack slots - Int, -- Number of non-pointer stack slots + :: [Id] -- Args + -> FCode ([(Id,GlobalReg)], -- Regs assigned + WordOff, -- Number of pointer stack slots + WordOff, -- Number of non-pointer stack slots VirtualSpOffset) -- Offset of return address slot -- (= realSP on entry) bindUnboxedTupleComponents args - = -- Assign as many components as possible to registers - let (arg_regs, _leftovers) = assignRegs [] (map idPrimRep args) - (reg_args, stk_args) = splitAtList arg_regs args - - -- separate the rest of the args into pointers and non-pointers - (ptr_args, nptr_args) = - partition (isFollowableRep . idPrimRep) stk_args - in + = do { + vsp <- getVirtSp + ; rsp <- getRealSp + + -- Assign as many components as possible to registers + ; let (reg_args, stk_args) = assignReturnRegs (addIdReps args) + + -- Separate the rest of the args into pointers and non-pointers + (ptr_args, nptr_args) = separateByPtrFollowness stk_args - -- Allocate the rest on the stack - -- The real SP points to the return address, above which any - -- leftover unboxed-tuple components will be allocated - getVirtSp `thenFC` \ vsp -> - getRealSp `thenFC` \ rsp -> - let - (ptr_sp, ptr_offsets) = mkVirtStkOffsets rsp idPrimRep ptr_args - (nptr_sp, nptr_offsets) = mkVirtStkOffsets ptr_sp idPrimRep nptr_args - ptrs = ptr_sp - rsp - nptrs = nptr_sp - ptr_sp - in - - -- The stack pointer points to the last stack-allocated component - setRealAndVirtualSp nptr_sp `thenC` - - -- We have just allocated slots starting at real SP + 1, and set the new - -- virtual SP to the topmost allocated slot. - -- If the virtual SP started *below* the real SP, we've just jumped over - -- some slots that won't be in the free-list, so put them there - -- This commonly happens because we've freed the return-address slot - -- (trimming back the virtual SP), but the real SP still points to that slot - freeStackSlots [vsp+1,vsp+2 .. rsp] `thenC` - - bindArgsToRegs reg_args arg_regs `thenC` - mapCs bindNewToStack ptr_offsets `thenC` - mapCs bindNewToStack nptr_offsets `thenC` - - returnFC (arg_regs, ptrs, nptrs, rsp) + -- Allocate the rest on the stack + -- The real SP points to the return address, above which any + -- leftover unboxed-tuple components will be allocated + (ptr_sp, ptr_offsets) = mkVirtStkOffsets rsp ptr_args + (nptr_sp, nptr_offsets) = mkVirtStkOffsets ptr_sp nptr_args + ptrs = ptr_sp - rsp + nptrs = nptr_sp - ptr_sp + + -- The stack pointer points to the last stack-allocated component + ; setRealAndVirtualSp nptr_sp + + -- We have just allocated slots starting at real SP + 1, and set the new + -- virtual SP to the topmost allocated slot. + -- If the virtual SP started *below* the real SP, we've just jumped over + -- some slots that won't be in the free-list, so put them there + -- This commonly happens because we've freed the return-address slot + -- (trimming back the virtual SP), but the real SP still points to that slot + ; freeStackSlots [vsp+1,vsp+2 .. rsp] + + ; bindArgsToRegs reg_args + ; bindArgsToStack ptr_offsets + ; bindArgsToStack nptr_offsets + + ; returnFC (reg_args, ptrs, nptrs, rsp) } \end{code} %************************************************************************ %* * -\subsubsection[CgRetConv-cgReturnDataCon]{Actually generate code for a constructor return} + Actually generate code for a constructor return %* * %************************************************************************ @@ -285,47 +286,41 @@ bindUnboxedTupleComponents args Note: it's the responsibility of the @cgReturnDataCon@ caller to be sure the @amodes@ passed don't conflict with each other. \begin{code} -cgReturnDataCon :: DataCon -> [CAddrMode] -> Code +cgReturnDataCon :: DataCon -> [(CgRep, CmmExpr)] -> Code cgReturnDataCon con amodes = ASSERT( amodes `lengthIs` dataConRepArity con ) - getEndOfBlockInfo `thenFC` \ (EndOfBlockInfo args_sp sequel) -> - - case sequel of - - CaseAlts _ (Just (alts, Just (deflt_bndr, (_,deflt_lbl)))) False - | not (dataConTag con `is_elem` map fst alts) - -> - -- Special case! We're returning a constructor to the default case - -- of an enclosing case. For example: - -- - -- case (case e of (a,b) -> C a b) of - -- D x -> ... - -- y -> ...... - -- - -- In this case, - -- if the default is a non-bind-default (ie does not use y), - -- then we should simply jump to the default join point; - - if isDeadBinder deflt_bndr - then performReturn AbsCNop {- No reg assts -} jump_to_join_point - else build_it_then jump_to_join_point - where - is_elem = isIn "cgReturnDataCon" - jump_to_join_point sequel = absC (CJump (CLbl deflt_lbl CodePtrRep)) - -- Ignore the sequel: we've already looked at it above - - other_sequel -- The usual case - | isUnboxedTupleCon con -> returnUnboxedTuple amodes - | otherwise -> build_it_then (mkStaticAlgReturnCode con) - + do { EndOfBlockInfo _ sequel <- getEndOfBlockInfo + ; case sequel of + CaseAlts _ (Just (alts, deflt_lbl)) bndr _ + -> -- Ho! We know the constructor so we can + -- go straight to the right alternative + case assocMaybe alts (dataConTagZ con) of { + Just join_lbl -> build_it_then (jump_to join_lbl) ; + Nothing + -- Special case! We're returning a constructor to the default case + -- of an enclosing case. For example: + -- + -- case (case e of (a,b) -> C a b) of + -- D x -> ... + -- y -> ...... + -- + -- In this case, + -- if the default is a non-bind-default (ie does not use y), + -- then we should simply jump to the default join point; + + | isDeadBinder bndr -> performReturn (jump_to deflt_lbl) + | otherwise -> build_it_then (jump_to deflt_lbl) } + + other_sequel -- The usual case + | isUnboxedTupleCon con -> returnUnboxedTuple amodes + | otherwise -> build_it_then (emitKnownConReturnCode con) + } where - move_to_reg :: CAddrMode -> MagicId -> AbstractC - move_to_reg src_amode dest_reg = CAssign (CReg dest_reg) src_amode - - build_it_then return = - -- BUILD THE OBJECT IN THE HEAP - -- The first "con" says that the name bound to this + jump_to lbl = stmtC (CmmJump (CmmLit (CmmLabel lbl)) []) + build_it_then return_code + = do { -- BUILD THE OBJECT IN THE HEAP + -- The first "con" says that the name bound to this -- closure is "con", which is a bit of a fudge, but it only -- affects profiling @@ -333,12 +328,108 @@ cgReturnDataCon con amodes -- temporary variable, if the closure is a CHARLIKE. -- funnily enough, this makes the unique always come -- out as '54' :-) - buildDynCon (dataConWorkId con) currentCCS con amodes `thenFC` \ idinfo -> - idInfoToAmode PtrRep idinfo `thenFC` \ amode -> + tickyReturnNewCon (length amodes) + ; idinfo <- buildDynCon (dataConWorkId con) currentCCS con amodes + ; amode <- idInfoToAmode idinfo + ; checkedAbsC (CmmAssign nodeReg amode) + ; performReturn return_code } +\end{code} - -- RETURN - profCtrC FSLIT("TICK_RET_NEW") [mkIntCLit (length amodes)] `thenC` - -- could use doTailCall here. - performReturn (move_to_reg amode node) return +%************************************************************************ +%* * + Generating static stuff for algebraic data types +%* * +%************************************************************************ + + [These comments are rather out of date] + +\begin{tabular}{lll} +Info tbls & Macro & Kind of constructor \\ +\hline +info & @CONST_INFO_TABLE@& Zero arity (no info -- compiler uses static closure)\\ +info & @CHARLIKE_INFO_TABLE@& Charlike (no info -- compiler indexes fixed array)\\ +info & @INTLIKE_INFO_TABLE@& Intlike; the one macro generates both info tbls\\ +info & @SPEC_INFO_TABLE@& SPECish, and bigger than or equal to @MIN_UPD_SIZE@\\ +info & @GEN_INFO_TABLE@& GENish (hence bigger than or equal to @MIN_UPD_SIZE@)\\ +\end{tabular} + +Possible info tables for constructor con: + +\begin{description} +\item[@_con_info@:] +Used for dynamically let(rec)-bound occurrences of +the constructor, and for updates. For constructors +which are int-like, char-like or nullary, when GC occurs, +the closure tries to get rid of itself. + +\item[@_static_info@:] +Static occurrences of the constructor +macro: @STATIC_INFO_TABLE@. +\end{description} + +For zero-arity constructors, \tr{con}, we NO LONGER generate a static closure; +it's place is taken by the top level defn of the constructor. + +For charlike and intlike closures there is a fixed array of static +closures predeclared. + +\begin{code} +cgTyCon :: TyCon -> FCode [Cmm] -- each constructor gets a separate Cmm +cgTyCon tycon + = do { constrs <- mapM (getCmm . cgDataCon) (tyConDataCons tycon) + + -- Generate a table of static closures for an enumeration type + -- Put the table after the data constructor decls, because the + -- datatype closure table (for enumeration types) + -- to (say) PrelBase_$wTrue_closure, which is defined in code_stuff + ; extra <- + if isEnumerationTyCon tycon then do + tbl <- getCmm (emitRODataLits (mkClosureTblLabel + (tyConName tycon)) + [ CmmLabel (mkClosureLabel (dataConName con)) + | con <- tyConDataCons tycon]) + return [tbl] + else + return [] + + ; return (extra ++ constrs) + } +\end{code} + +Generate the entry code, info tables, and (for niladic constructor) the +static closure, for a constructor. + +\begin{code} +cgDataCon :: DataCon -> Code +cgDataCon data_con + = do { -- Don't need any dynamic closure code for zero-arity constructors + whenC (not (isNullaryDataCon data_con)) + (emit_info dyn_cl_info tickyEnterDynCon) + + -- Dynamic-Closure first, to reduce forward references + ; emit_info static_cl_info tickyEnterStaticCon } + + where + emit_info cl_info ticky_code + = do { code_blks <- getCgStmts the_code + ; emitClosureCodeAndInfoTable cl_info [] code_blks } + where + the_code = do { ticky_code + ; ldvEnter (CmmReg nodeReg) + ; body_code } + + arg_reps :: [(CgRep, Type)] + arg_reps = [(typeCgRep ty, ty) | ty <- dataConRepArgTys data_con] + + -- To allow the debuggers, interpreters, etc to cope with static + -- data structures (ie those built at compile time), we take care that + -- info-table contains the information we need. + (static_cl_info, _) = layOutStaticConstr data_con arg_reps + (dyn_cl_info, arg_things) = layOutDynConstr data_con arg_reps + + body_code = do { -- NB: We don't set CC when entering data (WDP 94/06) + tickyReturnOldCon (length arg_things) + ; performReturn (emitKnownConReturnCode data_con) } + -- noStmts: Ptr to thing already in Node \end{code} diff --git a/ghc/compiler/codeGen/CgConTbls.lhs b/ghc/compiler/codeGen/CgConTbls.lhs deleted file mode 100644 index 37ced1ee2b..0000000000 --- a/ghc/compiler/codeGen/CgConTbls.lhs +++ /dev/null @@ -1,163 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% -\section[CgConTbls]{Info tables and update bits for constructors} - -\begin{code} -module CgConTbls ( genStaticConBits ) where - -#include "HsVersions.h" - -import AbsCSyn -import CgMonad - -import AbsCUtils ( mkAbstractCs, mkAbsCStmts ) -import CgTailCall ( performReturn, mkStaticAlgReturnCode ) -import ClosureInfo ( layOutStaticConstr, layOutDynConstr, ClosureInfo ) -import DataCon ( DataCon, dataConRepArgTys, isNullaryDataCon ) -import TyCon ( tyConDataCons, isEnumerationTyCon, TyCon ) -import Type ( typePrimRep ) -import CmdLineOpts -\end{code} - -For every constructor we generate the following info tables: - A static info table, for static instances of the constructor, - - Plus: - -\begin{tabular}{lll} -Info tbls & Macro & Kind of constructor \\ -\hline -info & @CONST_INFO_TABLE@& Zero arity (no info -- compiler uses static closure)\\ -info & @CHARLIKE_INFO_TABLE@& Charlike (no info -- compiler indexes fixed array)\\ -info & @INTLIKE_INFO_TABLE@& Intlike; the one macro generates both info tbls\\ -info & @SPEC_INFO_TABLE@& SPECish, and bigger than or equal to @MIN_UPD_SIZE@\\ -info & @GEN_INFO_TABLE@& GENish (hence bigger than or equal to @MIN_UPD_SIZE@)\\ -\end{tabular} - -Possible info tables for constructor con: - -\begin{description} -\item[@_con_info@:] -Used for dynamically let(rec)-bound occurrences of -the constructor, and for updates. For constructors -which are int-like, char-like or nullary, when GC occurs, -the closure tries to get rid of itself. - -\item[@_static_info@:] -Static occurrences of the constructor -macro: @STATIC_INFO_TABLE@. -\end{description} - - -For zero-arity constructors, \tr{con}, we NO LONGER generate a static closure; -it's place is taken by the top level defn of the constructor. - -For charlike and intlike closures there is a fixed array of static -closures predeclared. - -\begin{code} -genStaticConBits :: CompilationInfo -- global info about the compilation - -> [TyCon] -- tycons to generate - -> AbstractC -- output - -genStaticConBits comp_info gen_tycons - = -- for each type constructor: - -- grab all its data constructors; - -- for each one, generate an info table - -- for each specialised type constructor - -- for each specialisation of the type constructor - -- grab data constructors, and generate info tables - - -- ToDo: for tycons and specialisations which are not - -- declared in this module we must ensure that the - -- C labels are local to this module i.e. static - -- since they may be duplicated in other modules - - mkAbstractCs [ gen_for_tycon tc `mkAbsCStmts` enum_closure_table tc - | tc <- gen_tycons ] - where - gen_for_tycon :: TyCon -> AbstractC - gen_for_tycon tycon = mkAbstractCs [ genConInfo comp_info data_con - | data_con <- tyConDataCons tycon ] - - enum_closure_table tycon - | isEnumerationTyCon tycon = CClosureTbl tycon - | otherwise = AbsCNop - -- Put the table after the data constructor decls, because the - -- datatype closure table (for enumeration types) - -- to (say) PrelBase_$wTrue_closure, which is defined in code_stuff -\end{code} - - -%************************************************************************ -%* * -\subsection[CgConTbls-info-tables]{Generating info tables for constructors} -%* * -%************************************************************************ - -Generate the entry code, info tables, and (for niladic constructor) the -static closure, for a constructor. - -\begin{code} -genConInfo :: CompilationInfo -> DataCon -> AbstractC - -genConInfo comp_info data_con - = -- Order of things is to reduce forward references - mkAbstractCs [if opt_EnsureSplittableC then CSplitMarker else AbsCNop, - closure_code, - static_code] - where - (closure_info, body_code) = mkConCodeAndInfo data_con - - -- To allow the debuggers, interpreters, etc to cope with static - -- data structures (ie those built at compile time), we take care that - -- info-table contains the information we need. - (static_ci,_) = layOutStaticConstr data_con typePrimRep arg_tys - - static_body = initC comp_info ( - profCtrC FSLIT("TICK_ENT_STATIC_CON") [CReg node] `thenC` - ldv_enter_and_body_code) - - closure_body = initC comp_info ( - profCtrC FSLIT("TICK_ENT_DYN_CON") [CReg node] `thenC` - ldv_enter_and_body_code) - - ldv_enter_and_body_code = ldvEnter `thenC` body_code - - -- Don't need any dynamic closure code for zero-arity constructors - closure_code = if zero_arity_con then - AbsCNop - else - CClosureInfoAndCode closure_info closure_body - - static_code = CClosureInfoAndCode static_ci static_body - - zero_arity_con = isNullaryDataCon data_con - -- We used to check that all the arg-sizes were zero, but we don't - -- really have any constructors with only zero-size args, and it's - -- just one more thing to go wrong. - - arg_tys = dataConRepArgTys data_con -\end{code} - -\begin{code} -mkConCodeAndInfo :: DataCon -- Data constructor - -> (ClosureInfo, Code) -- The info table - -mkConCodeAndInfo con - = let - arg_tys = dataConRepArgTys con - - (closure_info, arg_things) = layOutDynConstr con typePrimRep arg_tys - - body_code - = -- NB: We don't set CC when entering data (WDP 94/06) - profCtrC FSLIT("TICK_RET_OLD") - [mkIntCLit (length arg_things)] `thenC` - - performReturn AbsCNop -- Ptr to thing already in Node - (mkStaticAlgReturnCode con) - in - (closure_info, body_code) -\end{code} diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs index 88771b911c..d72c7c5a4c 100644 --- a/ghc/compiler/codeGen/CgExpr.lhs +++ b/ghc/compiler/codeGen/CgExpr.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgExpr.lhs,v 1.58 2004/08/10 09:02:41 simonmar Exp $ +% $Id: CgExpr.lhs,v 1.59 2004/08/13 13:05:58 simonmar Exp $ % %******************************************************** %* * @@ -17,38 +17,39 @@ module CgExpr ( cgExpr ) where import Constants ( mAX_SPEC_SELECTEE_SIZE, mAX_SPEC_AP_SIZE ) import StgSyn import CgMonad -import AbsCSyn -import AbsCUtils ( mkAbstractCs, getAmodeRep, shimFCallArg ) -import CLabel ( mkClosureTblLabel ) -import SMRep ( fixedHdrSize ) +import SMRep ( fixedHdrSize, isFollowableArg, CgRep(..), argMachRep, + nonVoidArg, idCgRep, typeCgRep, typeHint, + primRepToCgRep ) import CoreSyn ( AltCon(..) ) +import CgProf ( emitSetCCC ) +import CgHeapery ( layOutDynConstr ) import CgBindery ( getArgAmodes, getArgAmode, CgIdInfo, nukeDeadBindings, addBindC, addBindsC ) import CgCase ( cgCase, saveVolatileVarsAndRegs ) import CgClosure ( cgRhsClosure, cgStdRhsClosure ) import CgCon ( buildDynCon, cgReturnDataCon ) import CgLetNoEscape ( cgLetNoEscapeClosure ) -import CgRetConv ( dataReturnConvPrim ) -import CgTailCall ( cgTailCall, performReturn, performPrimReturn, - mkDynamicAlgReturnCode, mkPrimReturnCode, - tailCallPrimOp, ccallReturnUnboxedTuple - ) -import ClosureInfo ( mkClosureLFInfo, mkSelectorLFInfo, - mkApLFInfo, layOutDynConstr ) -import CostCentre ( sccAbleCostCentre, isSccCountCostCentre ) -import Id ( idPrimRep, Id ) +import CgCallConv ( dataReturnConvPrim ) +import CgTailCall +import CgInfoTbls ( emitDirectReturnInstr ) +import CgForeignCall ( emitForeignCall, shimForeignCallArg ) +import CgPrimOp ( cgPrimOp ) +import CgUtils ( addIdReps, newTemp, assignTemp, cgLit, tagToClosure ) +import ClosureInfo ( mkSelectorLFInfo, mkApLFInfo ) +import Cmm ( CmmExpr(..), CmmStmt(..), CmmReg, nodeReg ) +import MachOp ( wordRep, MachHint ) import VarSet +import Literal ( literalType ) import PrimOp ( primOpOutOfLine, getPrimOpResultInfo, PrimOp(..), PrimOpResultInfo(..) ) -import PrimRep ( PrimRep(..), isFollowableRep ) +import Id ( Id ) import TyCon ( isUnboxedTupleTyCon, isEnumerationTyCon ) -import Type ( Type, typePrimRep, tyConAppArgs, - tyConAppTyCon, repType ) +import Type ( Type, tyConAppArgs, tyConAppTyCon, repType, + PrimRep(VoidRep) ) import Maybes ( maybeToBool ) import ListSetOps ( assocMaybe ) -import Unique ( mkBuiltinUnique ) -import BasicTypes ( TopLevelFlag(..), RecFlag(..) ) +import BasicTypes ( RecFlag(..) ) import Util ( lengthIs ) import Outputable \end{code} @@ -84,8 +85,8 @@ cgExpr (StgApp fun args) = cgTailCall fun args \begin{code} cgExpr (StgConApp con args) - = getArgAmodes args `thenFC` \ amodes -> - cgReturnDataCon con amodes + = do { amodes <- getArgAmodes args + ; cgReturnDataCon con amodes } \end{code} Literals are similar to constructors; they return by putting @@ -94,99 +95,100 @@ top of the stack. \begin{code} cgExpr (StgLit lit) - = performPrimReturn (text "literal" <+> ppr lit) (CLit lit) + = do { cmm_lit <- cgLit lit + ; performPrimReturn rep (CmmLit cmm_lit) } + where + rep = typeCgRep (literalType lit) \end{code} %******************************************************** %* * -%* STG PrimApps (unboxed primitive ops) * +%* PrimOps and foreign calls. %* * %******************************************************** -Here is where we insert real live machine instructions. - -NOTE about _ccall_GC_: +NOTE about "safe" foreign calls: a safe foreign call is never compiled +inline in a case expression. When we see -A _ccall_GC_ is treated as an out-of-line primop (returns True -for primOpOutOfLine) so that when we see the call in case context case (ccall ...) of { ... } -we get a proper stack frame on the stack when we perform it. When we -get in a tail-call position, however, we need to actually perform the -call, so we treat it as an inline primop. + +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 op@(StgFCallOp _ _) args res_ty) - = primRetUnboxedTuple op args res_ty +cgExpr (StgOpApp (StgFCallOp fcall _) stg_args res_ty) = do + {- + 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 stg_arg expr + | (stg_arg, (rep,expr)) <- stg_args `zip` reps_n_amodes, + nonVoidArg rep] + -- in + arg_tmps <- mapM assignTemp arg_exprs + let + arg_hints = zip arg_tmps (map (typeHint.stgArgType) stg_args) + -- in + {- + Now, allocate some result regs. + -} + (res_reps,res_regs,res_hints) <- newUnboxedTupleRegs res_ty + ccallReturnUnboxedTuple (zip res_reps (map CmmReg res_regs)) $ + emitForeignCall (zip 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) - getArgAmode arg `thenFC` \amode -> - -- save the tag in a temporary in case amode overlaps - -- with node. - absC (CAssign dyn_tag amode) `thenC` - performReturn ( - CAssign (CReg node) - (CVal (CIndex - (CLbl (mkClosureTblLabel tycon) PtrRep) - dyn_tag PtrRep) PtrRep)) - (\ sequel -> mkDynamicAlgReturnCode tycon dyn_tag sequel) + do { (_,amode) <- getArgAmode arg + ; amode' <- assignTemp amode -- We're going to use it twice, + -- so save in a temp if non-trivial + ; stmtC (CmmAssign nodeReg (tagToClosure tycon amode')) + ; performReturn (emitAlgReturnCode tycon amode') } where - dyn_tag = CTemp (mkBuiltinUnique 0) IntRep - -- The '0' is just to get a random spare temp - -- - -- if you're reading this code in the attempt to figure + -- If you're reading this code in the attempt to figure -- out why the compiler panic'ed here, it is probably because -- you used tagToEnum# in a non-monomorphic setting, e.g., -- intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x# - -- -- That won't work. - -- tycon = tyConAppTyCon res_ty cgExpr x@(StgOpApp op@(StgPrimOp primop) args res_ty) - | primOpOutOfLine primop - = tailCallPrimOp primop args - - | otherwise - = getArgAmodes args `thenFC` \ arg_amodes -> - - case (getPrimOpResultInfo primop) of - - ReturnsPrim kind -> - let result_amode = CReg (dataReturnConvPrim kind) in - performReturn - (COpStmt [result_amode] op arg_amodes [{-no vol_regs-}]) - (mkPrimReturnCode (text "primapp)" <+> ppr x)) - - -- otherwise, must be returning an enumerated type (eg. Bool). - -- we've only got the tag in R2, so we have to load the constructor - -- itself into R1. - - ReturnsAlg tycon - | isUnboxedTupleTyCon tycon -> primRetUnboxedTuple op args res_ty - - | isEnumerationTyCon tycon -> - performReturn - (COpStmt [dyn_tag] op arg_amodes [{-no vol_regs-}]) - (\ sequel -> - absC (CAssign (CReg node) closure_lbl) `thenC` - mkDynamicAlgReturnCode tycon dyn_tag sequel) - - where - -- Pull a unique out of thin air to put the tag in. - -- It shouldn't matter if this overlaps with anything - we're - -- about to return anyway. - dyn_tag = CTemp (mkBuiltinUnique 0) IntRep - - closure_lbl = CVal (CIndex - (CLbl (mkClosureTblLabel tycon) PtrRep) - dyn_tag PtrRep) PtrRep - + | primOpOutOfLine primop + = tailCallPrimOp primop args + + | ReturnsPrim VoidRep <- result_info + = do cgPrimOp [] primop args emptyVarSet + performReturn emitDirectReturnInstr + + | ReturnsPrim rep <- result_info + = do cgPrimOp [dataReturnConvPrim (primRepToCgRep rep)] + primop args emptyVarSet + performReturn emitDirectReturnInstr + + | ReturnsAlg tycon <- result_info, isUnboxedTupleTyCon tycon + = do (reps, regs, _hints) <- newUnboxedTupleRegs res_ty + cgPrimOp regs primop args emptyVarSet{-no live vars-} + returnUnboxedTuple (zip reps (map CmmReg regs)) + + | ReturnsAlg tycon <- result_info, isEnumerationTyCon tycon + -- c.f. cgExpr (...TagToEnumOp...) + = do tag_reg <- newTemp wordRep + cgPrimOp [tag_reg] primop args emptyVarSet + stmtC (CmmAssign nodeReg (tagToClosure tycon (CmmReg tag_reg))) + performReturn (emitAlgReturnCode tycon (CmmReg tag_reg)) + where + result_info = getPrimOpResultInfo primop \end{code} %******************************************************** @@ -227,20 +229,21 @@ cgExpr (StgLet (StgRec pairs) expr) \begin{code} cgExpr (StgLetNoEscape live_in_whole_let live_in_rhss bindings body) - = -- Figure out what volatile variables to save - nukeDeadBindings live_in_whole_let `thenC` - saveVolatileVarsAndRegs live_in_rhss - `thenFC` \ (save_assts, rhs_eob_info, maybe_cc_slot) -> + = do { -- Figure out what volatile variables to save + ; nukeDeadBindings live_in_whole_let + ; (save_assts, rhs_eob_info, maybe_cc_slot) + <- saveVolatileVarsAndRegs live_in_rhss -- Save those variables right now! - absC save_assts `thenC` + ; emitStmts save_assts -- Produce code for the rhss -- and add suitable bindings to the environment - cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot bindings `thenC` + ; cgLetNoEscapeBindings live_in_rhss rhs_eob_info + maybe_cc_slot bindings -- Do the body - setEndOfBlockInfo rhs_eob_info (cgExpr body) + ; setEndOfBlockInfo rhs_eob_info (cgExpr body) } \end{code} @@ -252,18 +255,11 @@ cgExpr (StgLetNoEscape live_in_whole_let live_in_rhss bindings body) SCC expressions are treated specially. They set the current cost centre. + \begin{code} -cgExpr (StgSCC cc expr) - = ASSERT(sccAbleCostCentre cc) - costCentresC - FSLIT("SET_CCC") - [mkCCostCentre cc, mkIntCLit (if isSccCountCostCentre cc then 1 else 0)] - `thenC` - cgExpr expr +cgExpr (StgSCC cc expr) = do emitSetCCC cc; cgExpr expr \end{code} -ToDo: counting of dict sccs ... - %******************************************************** %* * %* Non-top-level bindings * @@ -279,9 +275,9 @@ cgRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo) -- the Id is passed along so a binding can be set up cgRhs name (StgRhsCon maybe_cc con args) - = getArgAmodes args `thenFC` \ amodes -> - buildDynCon name maybe_cc con amodes `thenFC` \ idinfo -> - returnFC (name, idinfo) + = do { amodes <- getArgAmodes args + ; idinfo <- buildDynCon name maybe_cc con amodes + ; returnFC (name, idinfo) } cgRhs name (StgRhsClosure cc bi fvs upd_flag srt args body) = mkRhsClosure name cc bi srt fvs upd_flag args body @@ -328,7 +324,7 @@ mkRhsClosure bndr cc bi srt cgStdRhsClosure bndr cc bi [the_fv] [] body lf_info [StgVarArg the_fv] where lf_info = mkSelectorLFInfo bndr offset_into_int (isUpdatable upd_flag) - (_, params_w_offsets) = layOutDynConstr con idPrimRep params + (_, params_w_offsets) = layOutDynConstr con (addIdReps params) -- Just want the layout maybe_offset = assocMaybe params_w_offsets selectee Just the_offset = maybe_offset @@ -359,7 +355,7 @@ mkRhsClosure bndr cc bi srt body@(StgApp fun_id args) | args `lengthIs` (arity-1) - && all isFollowableRep (map idPrimRep fvs) + && all isFollowableArg (map idCgRep fvs) && isUpdatable upd_flag && arity <= mAX_SPEC_AP_SIZE @@ -370,17 +366,15 @@ mkRhsClosure bndr cc bi srt lf_info = mkApLFInfo bndr upd_flag arity -- the payload has to be in the correct order, hence we can't -- just use the fvs. - payload = StgVarArg fun_id : args - arity = length fvs + payload = StgVarArg fun_id : args + arity = length fvs \end{code} The default case ~~~~~~~~~~~~~~~~ \begin{code} mkRhsClosure bndr cc bi srt fvs upd_flag args body - = cgRhsClosure bndr cc bi srt fvs args body lf_info - where - lf_info = mkClosureLFInfo bndr NotTopLevel fvs upd_flag args + = cgRhsClosure bndr cc bi srt fvs upd_flag args body \end{code} @@ -392,20 +386,19 @@ mkRhsClosure bndr cc bi srt fvs upd_flag args body \begin{code} cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgNonRec binder rhs) - = cgLetNoEscapeRhs live_in_rhss rhs_eob_info maybe_cc_slot - NonRecursive binder rhs - `thenFC` \ (binder, info) -> - addBindC binder info + = do { (binder,info) <- cgLetNoEscapeRhs live_in_rhss rhs_eob_info + maybe_cc_slot + NonRecursive binder rhs + ; addBindC binder info } cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgRec pairs) - = fixC (\ new_bindings -> - addBindsC new_bindings `thenC` - listFCs [ cgLetNoEscapeRhs full_live_in_rhss + = do { new_bindings <- fixC (\ new_bindings -> do + { addBindsC new_bindings + ; listFCs [ cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot Recursive b e - | (b,e) <- pairs ] - ) `thenFC` \ new_bindings -> + | (b,e) <- pairs ] }) - addBindsC new_bindings + ; addBindsC new_bindings } where -- We add the binders to the live-in-rhss set so that we don't -- delete the bindings for the binder from the environment! @@ -443,41 +436,15 @@ cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder Little helper for primitives that return unboxed tuples. - \begin{code} -primRetUnboxedTuple :: StgOp -> [StgArg] -> Type -> Code -primRetUnboxedTuple op args res_ty - = getArgAmodes args `thenFC` \ arg_amodes1 -> - {- - For a foreign call, we might need to fiddle with some of the args: - for example, when passing a ByteArray#, we pass a ptr to the goods - rather than the heap object. - -} - let - arg_amodes - | StgFCallOp{} <- op = zipWith shimFCallArg args arg_amodes1 - | otherwise = arg_amodes1 - in - {- - put all the arguments in temporaries so they don't get stomped when - we push the return address. - -} - let - n_args = length args - arg_uniqs = map mkBuiltinUnique [0 .. n_args-1] - arg_reps = map getAmodeRep arg_amodes - arg_temps = zipWith CTemp arg_uniqs arg_reps - in - absC (mkAbstractCs (zipWith CAssign arg_temps arg_amodes)) `thenC` - {- - allocate some temporaries for the return values. - -} - let - ty_args = tyConAppArgs (repType res_ty) - prim_reps = map typePrimRep ty_args - temp_uniqs = map mkBuiltinUnique [ n_args .. n_args + length ty_args - 1] - temp_amodes = zipWith CTemp temp_uniqs prim_reps - in - ccallReturnUnboxedTuple temp_amodes - (absC (COpStmt temp_amodes op arg_temps [])) +newUnboxedTupleRegs :: Type -> FCode ([CgRep], [CmmReg], [MachHint]) +newUnboxedTupleRegs res_ty = + let + ty_args = tyConAppArgs (repType res_ty) + (reps,hints) = unzip [ (rep, typeHint ty) | ty <- ty_args, + let rep = typeCgRep ty, + nonVoidArg rep ] + in do + regs <- mapM (newTemp . argMachRep) reps + return (reps,regs,hints) \end{code} diff --git a/ghc/compiler/codeGen/CgForeignCall.hs b/ghc/compiler/codeGen/CgForeignCall.hs new file mode 100644 index 0000000000..9a8ef9e0c4 --- /dev/null +++ b/ghc/compiler/codeGen/CgForeignCall.hs @@ -0,0 +1,216 @@ +----------------------------------------------------------------------------- +-- +-- Code generation for foreign calls. +-- +-- (c) The University of Glasgow 2004 +-- +----------------------------------------------------------------------------- + +module CgForeignCall ( + emitForeignCall, + cgForeignCall, + shimForeignCallArg, + emitSaveThreadState, -- will be needed by the Cmm parser + emitLoadThreadState, -- ditto + emitCloseNursery, + emitOpenNursery, + ) where + +#include "HsVersions.h" + +import StgSyn ( StgLiveVars, StgArg, stgArgType ) +import CgProf ( curCCS, curCCSAddr ) +import CgBindery ( getVolatileRegs, getArgAmodes ) +import CgMonad +import CgUtils ( cmmOffsetW, cmmOffsetB, cmmLoadIndexW, newTemp ) +import Type ( tyConAppTyCon, repType ) +import TysPrim +import CLabel ( mkForeignLabel, mkRtsCodeLabel ) +import Cmm +import CmmUtils +import MachOp +import SMRep +import ForeignCall +import Constants +import CmdLineOpts ( opt_SccProfilingOn ) +import Outputable + +import Monad ( when ) + +-- ----------------------------------------------------------------------------- +-- Code generation for Foreign Calls + +cgForeignCall + :: [(CmmReg,MachHint)] -- where to put the results + -> ForeignCall -- the op + -> [StgArg] -- arguments + -> StgLiveVars -- live vars, in case we need to save them + -> Code +cgForeignCall results fcall stg_args live + = do + reps_n_amodes <- getArgAmodes stg_args + let + -- Get the *non-void* args, and jiggle them with shimForeignCall + arg_exprs = [ shimForeignCallArg stg_arg expr + | (stg_arg, (rep,expr)) <- stg_args `zip` reps_n_amodes, + nonVoidArg rep] + + arg_hints = zip arg_exprs (map (typeHint.stgArgType) stg_args) + -- in + emitForeignCall results fcall arg_hints live + + +emitForeignCall + :: [(CmmReg,MachHint)] -- where to put the results + -> ForeignCall -- the op + -> [(CmmExpr,MachHint)] -- arguments + -> StgLiveVars -- live vars, in case we need to save them + -> Code + +emitForeignCall results (CCall (CCallSpec target cconv safety)) args live + | not (playSafe safety) + = do + vols <- getVolatileRegs live + stmtC (the_call vols) + + | otherwise -- it's a safe foreign call + = do + vols <- getVolatileRegs live + id <- newTemp wordRep + emitSaveThreadState + stmtC (CmmCall (CmmForeignCall suspendThread CCallConv) [(id,NoHint)] + [ (CmmReg (CmmGlobal BaseReg), NoHint) ] + Nothing{-save all; ToDo-} + ) + stmtC (the_call vols) + stmtC (CmmCall (CmmForeignCall resumeThread CCallConv) [] + [ (CmmReg id, NoHint) ] (Just vols) + ) + emitLoadThreadState + + where + (call_args, cmm_target) + = case target of + StaticTarget lbl -> (args, CmmLit (CmmLabel + (mkForeignLabel lbl Nothing False))) + -- ToDo: what about the size here? + -- it is currently tacked on by the NCG. + DynamicTarget -> case args of (fn,_):rest -> (rest, fn) + + the_call vols = CmmCall (CmmForeignCall cmm_target cconv) + results call_args (Just vols) + + +emitForeignCall results (DNCall _) args live + = panic "emitForeignCall: DNCall" + +suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("suspendThread"))) +resumeThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("resumeThread"))) + +-- ----------------------------------------------------------------------------- +-- Save/restore the thread state in the TSO + +-- This stuff can't be done in suspendThread/resumeThread, because it +-- refers to global registers which aren't available in the C world. + +emitSaveThreadState = do + -- CurrentTSO->sp = Sp; + stmtC $ CmmStore (cmmOffset stgCurrentTSO tso_SP) stgSp + emitCloseNursery + -- and save the current cost centre stack in the TSO when profiling: + when opt_SccProfilingOn $ + stmtC (CmmStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS) + + -- CurrentNursery->free = Hp+1; +emitCloseNursery = stmtC $ CmmStore nursery_bdescr_free (cmmOffsetW stgHp 1) + +emitLoadThreadState = do + tso <- newTemp wordRep + stmtsC [ + -- tso = CurrentTSO; + CmmAssign tso stgCurrentTSO, + -- Sp = tso->sp; + CmmAssign sp (CmmLoad (cmmOffset (CmmReg tso) tso_SP) + wordRep), + -- SpLim = tso->stack + RESERVED_STACK_WORDS; + CmmAssign spLim (cmmOffsetW (cmmOffset (CmmReg tso) tso_STACK) + rESERVED_STACK_WORDS) + ] + emitOpenNursery + -- and load the current cost centre stack from the TSO when profiling: + when opt_SccProfilingOn $ + stmtC (CmmStore curCCSAddr + (CmmLoad (cmmOffset (CmmReg tso) tso_CCCS) wordRep)) + +emitOpenNursery = stmtsC [ + -- Hp = CurrentNursery->free - 1; + CmmAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free wordRep) (-1)), + + -- HpLim = CurrentNursery->start + + -- CurrentNursery->blocks*BLOCK_SIZE_W - 1; + CmmAssign hpLim + (cmmOffsetExpr + (CmmLoad nursery_bdescr_start wordRep) + (cmmOffset + (CmmMachOp mo_wordMul [ + CmmMachOp (MO_S_Conv I32 wordRep) + [CmmLoad nursery_bdescr_blocks I32], + CmmLit (mkIntCLit bLOCK_SIZE) + ]) + (-1) + ) + ) + ] + + +nursery_bdescr_free = cmmOffset stgCurrentNursery oFFSET_bdescr_free +nursery_bdescr_start = cmmOffset stgCurrentNursery oFFSET_bdescr_start +nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks + +tso_SP = tsoFieldB oFFSET_StgTSO_sp +tso_STACK = tsoFieldB oFFSET_StgTSO_stack +tso_CCCS = tsoProfFieldB oFFSET_StgTSO_CCCS + +-- The TSO struct has a variable header, and an optional StgTSOProfInfo in +-- the middle. The fields we're interested in are after the StgTSOProfInfo. +tsoFieldB :: ByteOff -> ByteOff +tsoFieldB off + | opt_SccProfilingOn = off + sIZEOF_StgTSOProfInfo + fixedHdrSize * wORD_SIZE + | otherwise = off + fixedHdrSize * wORD_SIZE + +tsoProfFieldB :: ByteOff -> ByteOff +tsoProfFieldB off = off + fixedHdrSize * wORD_SIZE + +stgSp = CmmReg sp +stgHp = CmmReg hp +stgCurrentTSO = CmmReg currentTSO +stgCurrentNursery = CmmReg currentNursery + +sp = CmmGlobal Sp +spLim = CmmGlobal SpLim +hp = CmmGlobal Hp +hpLim = CmmGlobal HpLim +currentTSO = CmmGlobal CurrentTSO +currentNursery = CmmGlobal CurrentNursery + +-- ----------------------------------------------------------------------------- +-- For certain types passed to foreign calls, we adjust the actual +-- value passed to the call. Two main cases: for ForeignObj# we pass +-- the pointer inside the ForeignObj# closure, and for ByteArray#/Array# we +-- pass the address of the actual array, not the address of the heap object. + +shimForeignCallArg :: StgArg -> CmmExpr -> CmmExpr +shimForeignCallArg arg expr + | tycon == foreignObjPrimTyCon + = cmmLoadIndexW expr fixedHdrSize + + | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon + = cmmOffsetB expr arrPtrsHdrSize + + | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon + = cmmOffsetB expr arrWordsHdrSize + + | otherwise = expr + where + -- should be a tycon app, since this is a foreign call + tycon = tyConAppTyCon (repType (stgArgType arg)) diff --git a/ghc/compiler/codeGen/CgHeapery.lhs b/ghc/compiler/codeGen/CgHeapery.lhs index 2329dcb6d2..6abffe72dc 100644 --- a/ghc/compiler/codeGen/CgHeapery.lhs +++ b/ghc/compiler/codeGen/CgHeapery.lhs @@ -1,43 +1,234 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgHeapery.lhs,v 1.39 2003/07/28 16:05:35 simonmar Exp $ +% $Id: CgHeapery.lhs,v 1.40 2004/08/13 13:06:00 simonmar Exp $ % \section[CgHeapery]{Heap management functions} \begin{code} module CgHeapery ( - funEntryChecks, altHeapCheck, unbxTupleHeapCheck, thunkChecks, - allocDynClosure, + initHeapUsage, getVirtHp, setVirtHp, setRealHp, + getHpRelOffset, hpRel, - -- new functions, basically inserting macro calls into Code -- HWL - ,fetchAndReschedule, yield + funEntryChecks, thunkEntryChecks, + altHeapCheck, unbxTupleHeapCheck, + hpChkGen, hpChkNodePointsAssignSp0, + stkChkGen, stkChkNodePoints, + + layOutDynConstr, layOutStaticConstr, + mkVirtHeapOffsets, mkStaticClosureFields, mkStaticClosure, + + allocDynClosure, emitSetDynHdr ) where #include "HsVersions.h" -import AbsCSyn +import Constants ( mIN_UPD_SIZE ) import StgSyn ( AltType(..) ) -import CLabel +import CLabel ( CLabel, mkRtsCodeLabel ) +import CgUtils ( mkWordCLit, cmmRegOffW, cmmOffsetW, + cmmOffsetExprB ) import CgMonad -import CgStackery ( getFinalStackHW ) -import AbsCUtils ( mkAbstractCs, getAmodeRep ) -import CgUsages ( getVirtAndRealHp, getRealSp, setVirtHp, setRealHp, - initHeapUsage - ) -import CgRetConv ( dataReturnConvPrim ) -import ClosureInfo ( closureSize, closureGoodStuffSize, - slopSize, allocProfilingMsg, ClosureInfo - ) +import CgProf ( staticProfHdr, profDynAlloc, dynProfHdr ) +import CgTicky ( staticTickyHdr, tickyDynAlloc, tickyAllocHeap ) +import CgParallel ( staticGranHdr, staticParHdr, doGranAllocate ) +import CgStackery ( getFinalStackHW, getRealSp ) +import CgCallConv ( mkRegLiveness ) +import ClosureInfo ( closureSize, closureUpdReqd, + staticClosureNeedsLink, + mkConInfo, + infoTableLabelFromCI, closureLabelFromCI, + nodeMustPointToIt, closureLFInfo, + ClosureInfo ) +import SMRep ( CgRep(..), cgRepSizeW, separateByPtrFollowness, + WordOff, fixedHdrSize, isVoidArg, primRepToCgRep ) + +import Cmm ( CmmLit(..), CmmStmt(..), CmmExpr(..), GlobalReg(..), + CmmReg(..), hpReg, nodeReg, spReg ) +import MachOp ( mo_wordULt, mo_wordUGt, mo_wordSub ) +import CmmUtils ( mkIntCLit, CmmStmts, noStmts, oneStmt, plusStmts, + mkStmts ) +import Id ( Id ) +import DataCon ( DataCon ) import TyCon ( tyConPrimRep ) -import PrimRep ( PrimRep(..), isFollowableRep ) -import CmdLineOpts ( opt_GranMacros ) +import CostCentre ( CostCentreStack ) +import Util ( mapAccumL, filterOut ) +import Constants ( wORD_SIZE ) import Outputable -#ifdef DEBUG -import PprAbsC ( pprMagicId ) -#endif import GLAEXTS + +\end{code} + + +%************************************************************************ +%* * +\subsection[CgUsages-heapery]{Monad things for fiddling with heap usage} +%* * +%************************************************************************ + +The heap always grows upwards, so hpRel is easy + +\begin{code} +hpRel :: VirtualHpOffset -- virtual offset of Hp + -> VirtualHpOffset -- virtual offset of The Thing + -> WordOff -- integer word offset +hpRel hp off = off - hp +\end{code} + +@initHeapUsage@ applies a function to the amount of heap that it uses. +It initialises the heap usage to zeros, and passes on an unchanged +heap usage. + +It is usually a prelude to performing a GC check, so everything must +be in a tidy and consistent state. + +rje: Note the slightly suble fixed point behaviour needed here + +\begin{code} +initHeapUsage :: (VirtualHpOffset -> Code) -> Code +initHeapUsage fcode + = do { orig_hp_usage <- getHpUsage + ; setHpUsage initHpUsage + ; fixC (\heap_usage2 -> do + { fcode (heapHWM heap_usage2) + ; getHpUsage }) + ; setHpUsage orig_hp_usage } + +setVirtHp :: VirtualHpOffset -> Code +setVirtHp new_virtHp + = do { hp_usage <- getHpUsage + ; setHpUsage (hp_usage {virtHp = new_virtHp}) } + +getVirtHp :: FCode VirtualHpOffset +getVirtHp + = do { hp_usage <- getHpUsage + ; return (virtHp hp_usage) } + +setRealHp :: VirtualHpOffset -> Code +setRealHp new_realHp + = do { hp_usage <- getHpUsage + ; setHpUsage (hp_usage {realHp = new_realHp}) } + +getHpRelOffset :: VirtualHpOffset -> FCode CmmExpr +getHpRelOffset virtual_offset + = do { hp_usg <- getHpUsage + ; return (cmmRegOffW hpReg (hpRel (realHp hp_usg) virtual_offset)) } +\end{code} + + +%************************************************************************ +%* * + Layout of heap objects +%* * +%************************************************************************ + +\begin{code} +layOutDynConstr, layOutStaticConstr + :: DataCon + -> [(CgRep,a)] + -> (ClosureInfo, + [(a,VirtualHpOffset)]) + +layOutDynConstr = layOutConstr False +layOutStaticConstr = layOutConstr True + +layOutConstr is_static data_con args + = (mkConInfo is_static data_con tot_wds ptr_wds, + things_w_offsets) + where + (tot_wds, -- #ptr_wds + #nonptr_wds + ptr_wds, -- #ptr_wds + things_w_offsets) = mkVirtHeapOffsets args +\end{code} + +@mkVirtHeapOffsets@ always returns boxed things with smaller offsets +than the unboxed things, and furthermore, the offsets in the result +list + +\begin{code} +mkVirtHeapOffsets + :: [(CgRep,a)] -- Things to make offsets for + -> (WordOff, -- *Total* number of words allocated + WordOff, -- Number of words allocated for *pointers* + [(a, VirtualHpOffset)]) + -- Things with their offsets from start of + -- object in order of increasing offset + +-- First in list gets lowest offset, which is initial offset + 1. + +mkVirtHeapOffsets things + = let non_void_things = filterOut (isVoidArg . fst) things + (ptrs, non_ptrs) = separateByPtrFollowness non_void_things + (wds_of_ptrs, ptrs_w_offsets) = mapAccumL computeOffset 0 ptrs + (tot_wds, non_ptrs_w_offsets) = mapAccumL computeOffset wds_of_ptrs non_ptrs + in + (tot_wds, wds_of_ptrs, ptrs_w_offsets ++ non_ptrs_w_offsets) + where + computeOffset wds_so_far (rep, thing) + = (wds_so_far + cgRepSizeW rep, (thing, fixedHdrSize + wds_so_far)) +\end{code} + + +%************************************************************************ +%* * + Lay out a static closure +%* * +%************************************************************************ + +Make a static closure, adding on any extra padding needed for CAFs, +and adding a static link field if necessary. + +\begin{code} +mkStaticClosureFields + :: ClosureInfo + -> CostCentreStack + -> Bool -- Has CAF refs + -> [CmmLit] -- Payload + -> [CmmLit] -- The full closure +mkStaticClosureFields cl_info ccs caf_refs payload + = mkStaticClosure info_lbl ccs payload padding_wds static_link_field + where + info_lbl = infoTableLabelFromCI cl_info + + upd_reqd = closureUpdReqd cl_info + + -- for the purposes of laying out the static closure, we consider all + -- thunks to be "updatable", so that the static link field is always + -- in the same place. + padding_wds + | not upd_reqd = [] + | otherwise = replicate n (mkIntCLit 0) -- a bunch of 0s + where n = max 0 (mIN_UPD_SIZE - length payload) + + -- We always have a static link field for a thunk, it's used to + -- save the closure's info pointer when we're reverting CAFs + -- (see comment in Storage.c) + static_link_field + | upd_reqd || staticClosureNeedsLink cl_info = [static_link_value] + | otherwise = [] + + -- for a static constructor which has NoCafRefs, we set the + -- static link field to a non-zero value so the garbage + -- collector will ignore it. + static_link_value + | caf_refs = mkIntCLit 0 + | otherwise = mkIntCLit 1 + +mkStaticClosure :: CLabel -> CostCentreStack -> [CmmLit] + -> [CmmLit] -> [CmmLit] -> [CmmLit] +mkStaticClosure info_lbl ccs payload padding_wds static_link_field + = [CmmLabel info_lbl] + ++ variable_header_words + ++ payload + ++ padding_wds + ++ static_link_field + where + variable_header_words + = staticGranHdr + ++ staticParHdr + ++ staticProfHdr ccs + ++ staticTickyHdr \end{code} %************************************************************************ @@ -54,86 +245,53 @@ beginning of every slow entry code in order to simulate the fetching of closures. If fetching is necessary (i.e. current closure is not local) then an automatic context switch is done. ------------------------------------------------------------------------------ +-------------------------------------------------------------- A heap/stack check at a function or thunk entry point. \begin{code} -funEntryChecks :: Maybe CLabel -> AbstractC -> Code -> Code -funEntryChecks closure_lbl reg_save_code code - = hpStkCheck closure_lbl True reg_save_code code - -thunkChecks :: Maybe CLabel -> Code -> Code -thunkChecks closure_lbl code - = hpStkCheck closure_lbl False AbsCNop code - -hpStkCheck - :: Maybe CLabel -- function closure - -> Bool -- is a function? (not a thunk) - -> AbstractC -- register saves - -> Code - -> Code - -hpStkCheck closure_lbl is_fun reg_save_code code - = getFinalStackHW (\ spHw -> - getRealSp `thenFC` \ sp -> - let stk_words = spHw - sp in - initHeapUsage (\ hHw -> - - getTickyCtrLabel `thenFC` \ ticky_ctr -> - - absC (checking_code stk_words hHw ticky_ctr) `thenC` - - setRealHp hHw `thenC` - code)) - +funEntryChecks :: ClosureInfo -> CmmStmts -> Code -> Code +funEntryChecks cl_info reg_save_code code + = hpStkCheck cl_info True reg_save_code code + +thunkEntryChecks :: ClosureInfo -> Code -> Code +thunkEntryChecks cl_info code + = hpStkCheck cl_info False noStmts code + +hpStkCheck :: ClosureInfo -- Function closure + -> Bool -- Is a function? (not a thunk) + -> CmmStmts -- Register saves + -> Code + -> Code + +hpStkCheck cl_info is_fun reg_save_code code + = getFinalStackHW $ \ spHw -> do + { sp <- getRealSp + ; let stk_words = spHw - sp + ; initHeapUsage $ \ hpHw -> do + { -- Emit heap checks, but be sure to do it lazily so + -- that the conditionals on hpHw don't cause a black hole + codeOnly $ do + { do_checks stk_words hpHw full_save_code rts_label + ; tickyAllocHeap hpHw } + ; setRealHp hpHw + ; code } + } where - node_asst - | Just lbl <- closure_lbl = CAssign nodeReg (CLbl lbl PtrRep) - | otherwise = AbsCNop - - save_code = mkAbstractCs [node_asst, reg_save_code] - - checking_code stk hp ctr - = mkAbstractCs - [ if is_fun - then do_checks_fun stk hp save_code - else do_checks_np stk hp save_code, - if hp == 0 - then AbsCNop - else profCtrAbsC FSLIT("TICK_ALLOC_HEAP") - [ mkIntCLit hp, CLbl ctr DataPtrRep ] - ] - - --- For functions: - -do_checks_fun - :: Int -- stack headroom - -> Int -- heap headroom - -> AbstractC -- assignments to perform on failure - -> AbstractC -do_checks_fun 0 0 _ = AbsCNop -do_checks_fun 0 hp_words assts = - CCheck HP_CHK_FUN [ mkIntCLit hp_words ] assts -do_checks_fun stk_words 0 assts = - CCheck STK_CHK_FUN [ mkIntCLit stk_words ] assts -do_checks_fun stk_words hp_words assts = - CCheck HP_STK_CHK_FUN [ mkIntCLit stk_words, mkIntCLit hp_words ] assts - --- For thunks: - -do_checks_np - :: Int -- stack headroom - -> Int -- heap headroom - -> AbstractC -- assignments to perform on failure - -> AbstractC -do_checks_np 0 0 _ = AbsCNop -do_checks_np 0 hp_words assts = - CCheck HP_CHK_NP [ mkIntCLit hp_words ] assts -do_checks_np stk_words 0 assts = - CCheck STK_CHK_NP [ mkIntCLit stk_words ] assts -do_checks_np stk_words hp_words assts = - CCheck HP_STK_CHK_NP [ mkIntCLit stk_words, mkIntCLit hp_words ] assts + node_asst + | nodeMustPointToIt (closureLFInfo cl_info) + = noStmts + | otherwise + = oneStmt (CmmAssign nodeReg (CmmLit (CmmLabel closure_lbl))) + closure_lbl = closureLabelFromCI cl_info + + full_save_code = node_asst `plusStmts` reg_save_code + + rts_label | is_fun = CmmReg (CmmGlobal GCFun) + -- Function entry point + | otherwise = CmmReg (CmmGlobal GCEnter1) + -- Thunk or case return + -- In the thunk/case-return case, R1 points to a closure + -- which should be (re)-entered after GC \end{code} Heap checks in a case alternative are nice and easy, provided this is @@ -153,12 +311,6 @@ For primitive returns, we have an unlifted value in some register (either R1 or FloatReg1 or DblReg1). This means using specialised heap-check code for these cases. -For unboxed tuple returns, there are an arbitrary number of possibly -unboxed return values, some of which will be in registers, and the -others will be on the stack. We always organise the stack-resident -fields into pointers & non-pointers, and pass the number of each to -the heap check code. - \begin{code} altHeapCheck :: AltType -- PolyAlt, PrimAlt, AlgAlt, but *not* UbxTupAlt @@ -166,150 +318,183 @@ altHeapCheck -> Code -- Continuation -> Code altHeapCheck alt_type code - = initHeapUsage (\ hHw -> - do_heap_chk hHw `thenC` - setRealHp hHw `thenC` - code) + = initHeapUsage $ \ hpHw -> do + { codeOnly $ do + { do_checks 0 {- no stack chk -} hpHw + noStmts {- nothign to save -} + (rts_label alt_type) + ; tickyAllocHeap hpHw } + ; setRealHp hpHw + ; code } where - do_heap_chk :: HeapOffset -> Code - do_heap_chk words_required - = getTickyCtrLabel `thenFC` \ ctr -> - absC ( -- NB The conditional is inside the absC, - -- so the monadic stuff doesn't depend on - -- the value of words_required! - if words_required == 0 - then AbsCNop - else mkAbstractCs - [ CCheck (checking_code alt_type) - [mkIntCLit words_required] AbsCNop, - profCtrAbsC FSLIT("TICK_ALLOC_HEAP") - [ mkIntCLit words_required, CLbl ctr DataPtrRep ] - ]) - - checking_code PolyAlt - = HP_CHK_UNPT_R1 -- Do *not* enter R1 after a heap check in - -- a polymorphic case. It might be a function - -- and the entry code for a function (currently) - -- applies it - -- - -- However R1 is guaranteed to be a pointer - - checking_code (AlgAlt tc) - = HP_CHK_NP -- Enter R1 after the heap check; it's a pointer - -- The "NP" is short for "Node (R1) Points to it" + rts_label PolyAlt = CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "stg_gc_unpt_r1"))) + -- Do *not* enter R1 after a heap check in + -- a polymorphic case. It might be a function + -- and the entry code for a function (currently) + -- applies it + -- + -- However R1 is guaranteed to be a pointer + + rts_label (AlgAlt tc) = stg_gc_enter1 + -- Enter R1 after the heap check; it's a pointer - checking_code (PrimAlt tc) - = case dataReturnConvPrim (tyConPrimRep tc) of - VoidReg -> HP_CHK_NOREGS - FloatReg 1# -> HP_CHK_F1 - DoubleReg 1# -> HP_CHK_D1 - LongReg _ 1# -> HP_CHK_L1 - VanillaReg rep 1# - | isFollowableRep rep -> HP_CHK_UNPT_R1 -- R1 is boxed but unlifted: - | otherwise -> HP_CHK_UNBX_R1 -- R1 is unboxed -#ifdef DEBUG - other_reg -> pprPanic "CgHeapery.altHeapCheck" (ppr tc <+> pprMagicId other_reg) -#endif - --- Unboxed tuple alternatives and let-no-escapes (the two most annoying --- constructs to generate code for!): + rts_label (PrimAlt tc) + = CmmLit $ CmmLabel $ + case primRepToCgRep (tyConPrimRep tc) of + VoidArg -> mkRtsCodeLabel SLIT( "stg_gc_noregs") + FloatArg -> mkRtsCodeLabel SLIT( "stg_gc_f1") + DoubleArg -> mkRtsCodeLabel SLIT( "stg_gc_d1") + LongArg -> mkRtsCodeLabel SLIT( "stg_gc_l1") + -- R1 is boxed but unlifted: + PtrArg -> mkRtsCodeLabel SLIT( "stg_gc_unpt_r1") + -- R1 is unboxed: + NonPtrArg -> mkRtsCodeLabel SLIT( "stg_gc_unbx_r1") + + rts_label (UbxTupAlt _) = panic "altHeapCheck" +\end{code} + +Unboxed tuple alternatives and let-no-escapes (the two most annoying +constructs to generate code for!) For unboxed tuple returns, there +are an arbitrary number of possibly unboxed return values, some of +which will be in registers, and the others will be on the stack. We +always organise the stack-resident fields into pointers & +non-pointers, and pass the number of each to the heap check code. + +\begin{code} unbxTupleHeapCheck - :: [MagicId] -- live registers - -> Int -- no. of stack slots containing ptrs - -> Int -- no. of stack slots containing nonptrs - -> AbstractC -- code to insert in the failure path + :: [(Id, GlobalReg)] -- Live registers + -> WordOff -- no. of stack slots containing ptrs + -> WordOff -- no. of stack slots containing nonptrs + -> CmmStmts -- code to insert in the failure path -> Code -> Code unbxTupleHeapCheck regs ptrs nptrs fail_code code - -- we can't manage more than 255 pointers/non-pointers in a generic - -- heap check. + -- We can't manage more than 255 pointers/non-pointers + -- in a generic heap check. | ptrs > 255 || nptrs > 255 = panic "altHeapCheck" - | otherwise = initHeapUsage (\ hHw -> do_heap_chk hHw `thenC` code) + | otherwise + = initHeapUsage $ \ hpHw -> do + { codeOnly $ do { do_checks 0 {- no stack check -} hpHw + full_fail_code rts_label + ; tickyAllocHeap hpHw } + ; setRealHp hpHw + ; code } where - do_heap_chk words_required - = getTickyCtrLabel `thenFC` \ ctr -> - absC ( if words_required == 0 - then AbsCNop - else mkAbstractCs - [ checking_code words_required, - profCtrAbsC FSLIT("TICK_ALLOC_HEAP") - [ mkIntCLit words_required, CLbl ctr DataPtrRep ] - ] - ) `thenC` - setRealHp words_required - - liveness = I# (word2Int# (mkRegLiveness regs ptrs nptrs)) - checking_code words_required = CCheck HP_CHK_UNBX_TUPLE - [mkIntCLit words_required, - mkIntCLit liveness] - fail_code - --- build up a bitmap of the live pointer registers - -#if __GLASGOW_HASKELL__ >= 503 -shiftL = uncheckedShiftL# -#else -shiftL = shiftL# -#endif - -mkRegLiveness :: [MagicId] -> Int -> Int -> Word# -mkRegLiveness [] (I# ptrs) (I# nptrs) = - (int2Word# nptrs `shiftL` 16#) `or#` (int2Word# ptrs `shiftL` 24#) -mkRegLiveness (VanillaReg rep i : regs) ptrs nptrs | isFollowableRep rep - = ((int2Word# 1#) `shiftL` (i -# 1#)) `or#` mkRegLiveness regs ptrs nptrs -mkRegLiveness (_ : regs) ptrs nptrs = mkRegLiveness regs ptrs nptrs - --- The two functions below are only used in a GranSim setup --- Emit macro for simulating a fetch and then reschedule - -fetchAndReschedule :: [MagicId] -- Live registers - -> Bool -- Node reqd? - -> Code - -fetchAndReschedule regs node_reqd = - if (node `elem` regs || node_reqd) - then fetch_code `thenC` reschedule_code - else absC AbsCNop - where - liveness_mask = mkRegLiveness regs 0 0 - reschedule_code = absC (CMacroStmt GRAN_RESCHEDULE [ - mkIntCLit (I# (word2Int# liveness_mask)), - mkIntCLit (if node_reqd then 1 else 0)]) - - --HWL: generate GRAN_FETCH macro for GrAnSim - -- currently GRAN_FETCH and GRAN_FETCH_AND_RESCHEDULE are miai - fetch_code = absC (CMacroStmt GRAN_FETCH []) + full_fail_code = fail_code `plusStmts` oneStmt assign_liveness + assign_liveness = CmmAssign (CmmGlobal (VanillaReg 9)) -- Ho ho ho! + (CmmLit (mkWordCLit liveness)) + liveness = mkRegLiveness regs ptrs nptrs + rts_label = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("stg_gc_ut"))) + \end{code} -The @GRAN_YIELD@ macro is taken from JSM's code for Concurrent Haskell. It -allows to context-switch at places where @node@ is not alive (it uses the -@Continue@ rather than the @EnterNodeCode@ function in the RTS). We emit -this kind of macro at the beginning of the following kinds of basic bocks: -\begin{itemize} - \item Slow entry code where node is not alive (see @CgClosure.lhs@). Normally - we use @fetchAndReschedule@ at a slow entry code. - \item Fast entry code (see @CgClosure.lhs@). - \item Alternatives in case expressions (@CLabelledCode@ structures), provided - that they are not inlined (see @CgCases.lhs@). These alternatives will - be turned into separate functions. -\end{itemize} + +%************************************************************************ +%* * + Heap/Stack Checks. +%* * +%************************************************************************ + +When failing a check, we save a return address on the stack and +jump to a pre-compiled code fragment that saves the live registers +and returns to the scheduler. + +The return address in most cases will be the beginning of the basic +block in which the check resides, since we need to perform the check +again on re-entry because someone else might have stolen the resource +in the meantime. \begin{code} -yield :: [MagicId] -- Live registers - -> Bool -- Node reqd? - -> Code - -yield regs node_reqd = - if opt_GranMacros && node_reqd - then yield_code - else absC AbsCNop - where - liveness_mask = mkRegLiveness regs 0 0 - yield_code = - absC (CMacroStmt GRAN_YIELD - [mkIntCLit (I# (word2Int# liveness_mask))]) +do_checks :: WordOff -- Stack headroom + -> WordOff -- Heap headroom + -> CmmStmts -- Assignments to perform on failure + -> CmmExpr -- Rts address to jump to on failure + -> Code +do_checks 0 0 _ _ = nopC +do_checks stk hp reg_save_code rts_lbl + = do_checks' (CmmLit (mkIntCLit (stk*wORD_SIZE))) + (CmmLit (mkIntCLit (hp*wORD_SIZE))) + (stk /= 0) (hp /= 0) reg_save_code rts_lbl + +-- The offsets are now in *bytes* +do_checks' stk_expr hp_expr stk_nonzero hp_nonzero reg_save_code rts_lbl + = do { doGranAllocate hp_expr + + -- Emit a block for the heap-check-failure code + ; blk_id <- forkLabelledCode $ do + { whenC hp_nonzero $ + stmtC (CmmAssign (CmmGlobal HpAlloc) hp_expr) + ; emitStmts reg_save_code + ; stmtC (CmmJump rts_lbl []) } + + -- Check for stack overflow *FIRST*; otherwise + -- we might bumping Hp and then failing stack oflo + ; whenC stk_nonzero + (stmtC (CmmCondBranch stk_oflo blk_id)) + + ; whenC hp_nonzero + (stmtsC [CmmAssign hpReg + (cmmOffsetExprB (CmmReg hpReg) hp_expr), + CmmCondBranch hp_oflo blk_id]) + -- Bump heap pointer, and test for heap exhaustion + -- Note that we don't move the heap pointer unless the + -- stack check succeeds. Otherwise we might end up + -- with slop at the end of the current block, which can + -- confuse the LDV profiler. + } + where + -- Stk overflow if (Sp - stk_bytes < SpLim) + stk_oflo = CmmMachOp mo_wordULt + [CmmMachOp mo_wordSub [CmmReg spReg, stk_expr], + CmmReg (CmmGlobal SpLim)] + + -- Hp overflow if (Hpp > HpLim) + -- (Hp has been incremented by now) + -- HpLim points to the LAST WORD of valid allocation space. + hp_oflo = CmmMachOp mo_wordUGt + [CmmReg hpReg, CmmReg (CmmGlobal HpLim)] +\end{code} + +%************************************************************************ +%* * + Generic Heap/Stack Checks - used in the RTS +%* * +%************************************************************************ + +\begin{code} +hpChkGen :: CmmExpr -> CmmExpr -> CmmExpr -> Code +hpChkGen bytes liveness reentry + = do_checks' (CmmLit (mkIntCLit 0)) bytes False True assigns stg_gc_gen + where + assigns = mkStmts [ + CmmAssign (CmmGlobal (VanillaReg 9)) liveness, + CmmAssign (CmmGlobal (VanillaReg 10)) reentry + ] + +-- a heap check where R1 points to the closure to enter on return, and +-- we want to assign to Sp[0] on failure (used in AutoApply.cmm:BUILD_PAP). +hpChkNodePointsAssignSp0 :: CmmExpr -> CmmExpr -> Code +hpChkNodePointsAssignSp0 bytes sp0 + = do_checks' (CmmLit (mkIntCLit 0)) bytes False True assign stg_gc_enter1 + where assign = oneStmt (CmmStore (CmmReg spReg) sp0) + +stkChkGen :: CmmExpr -> CmmExpr -> CmmExpr -> Code +stkChkGen bytes liveness reentry + = do_checks' bytes (CmmLit (mkIntCLit 0)) True False assigns stg_gc_gen + where + assigns = mkStmts [ + CmmAssign (CmmGlobal (VanillaReg 9)) liveness, + CmmAssign (CmmGlobal (VanillaReg 10)) reentry + ] + +stkChkNodePoints :: CmmExpr -> Code +stkChkNodePoints bytes + = do_checks' bytes (CmmLit (mkIntCLit 0)) True False noStmts stg_gc_enter1 + +stg_gc_gen = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("stg_gc_gen"))) +stg_gc_enter1 = CmmReg (CmmGlobal GCEnter1) \end{code} %************************************************************************ @@ -324,47 +509,65 @@ to account for this. \begin{code} allocDynClosure :: ClosureInfo - -> CAddrMode -- Cost Centre to stick in the object - -> CAddrMode -- Cost Centre to blame for this alloc + -> CmmExpr -- Cost Centre to stick in the object + -> CmmExpr -- Cost Centre to blame for this alloc -- (usually the same; sometimes "OVERHEAD") - -> [(CAddrMode, VirtualHeapOffset)] -- Offsets from start of the object - -- ie Info ptr has offset zero. - -> FCode VirtualHeapOffset -- Returns virt offset of object + -> [(CmmExpr, VirtualHpOffset)] -- Offsets from start of the object + -- ie Info ptr has offset zero. + -> FCode VirtualHpOffset -- Returns virt offset of object -allocDynClosure closure_info use_cc blame_cc amodes_with_offsets - = getVirtAndRealHp `thenFC` \ (virtHp, realHp) -> +allocDynClosure cl_info use_cc blame_cc amodes_with_offsets + = do { virt_hp <- getVirtHp -- FIND THE OFFSET OF THE INFO-PTR WORD - -- virtHp points to last allocated word, ie 1 *before* the - -- info-ptr word of new object. - let info_offset = virtHp + 1 - - -- do_move IS THE ASSIGNMENT FUNCTION - do_move (amode, offset_from_start) - = CAssign (CVal (hpRel realHp - (info_offset + offset_from_start)) - (getAmodeRep amode)) - amode - in + ; let info_offset = virt_hp + 1 + -- info_offset is the VirtualHpOffset of the first + -- word of the new object + -- Remember, virtHp points to last allocated word, + -- ie 1 *before* the info-ptr word of new object. + + info_ptr = CmmLit (CmmLabel (infoTableLabelFromCI cl_info)) + hdr_w_offsets = initDynHdr info_ptr use_cc `zip` [0..] + -- SAY WHAT WE ARE ABOUT TO DO - profCtrC (allocProfilingMsg closure_info) - [mkIntCLit (closureGoodStuffSize closure_info), - mkIntCLit slop_size] `thenC` + ; profDynAlloc cl_info use_cc + -- ToDo: This is almost certainly wrong + -- We're ignoring blame_cc. But until we've + -- fixed the boxing hack in chooseDynCostCentres etc, + -- we're worried about making things worse by "fixing" + -- this part to use blame_cc! - -- GENERATE THE CODE - absC ( mkAbstractCs ( - [ CInitHdr closure_info - (CAddr (hpRel realHp info_offset)) - use_cc closure_size ] - ++ (map do_move amodes_with_offsets))) `thenC` + ; tickyDynAlloc cl_info - -- BUMP THE VIRTUAL HEAP POINTER - setVirtHp (virtHp + closure_size) `thenC` + -- ALLOCATE THE OBJECT + ; base <- getHpRelOffset info_offset + ; hpStore base (hdr_w_offsets ++ amodes_with_offsets) + -- BUMP THE VIRTUAL HEAP POINTER + ; setVirtHp (virt_hp + closureSize cl_info) + -- RETURN PTR TO START OF OBJECT - returnFC info_offset - where - closure_size = closureSize closure_info - slop_size = slopSize closure_info + ; returnFC info_offset } + + +initDynHdr :: CmmExpr + -> CmmExpr -- Cost centre to put in object + -> [CmmExpr] +initDynHdr info_ptr cc + = [info_ptr] + -- ToDo: Gransim stuff + -- ToDo: Parallel stuff + ++ dynProfHdr cc + -- No ticky header + +hpStore :: CmmExpr -> [(CmmExpr, VirtualHpOffset)] -> Code +-- Store the item (expr,off) in base[off] +hpStore base es + = stmtsC [ CmmStore (cmmOffsetW base off) val + | (val, off) <- es ] + +emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> Code +emitSetDynHdr base info_ptr ccs + = hpStore base (zip (initDynHdr info_ptr ccs) [0..]) \end{code} diff --git a/ghc/compiler/codeGen/CgInfoTbls.hs b/ghc/compiler/codeGen/CgInfoTbls.hs new file mode 100644 index 0000000000..2f1007384f --- /dev/null +++ b/ghc/compiler/codeGen/CgInfoTbls.hs @@ -0,0 +1,538 @@ +----------------------------------------------------------------------------- +-- +-- Building info tables. +-- +-- (c) The University of Glasgow 2004 +-- +----------------------------------------------------------------------------- + +module CgInfoTbls ( + emitClosureCodeAndInfoTable, + emitInfoTableAndCode, + dataConTagZ, + getSRTInfo, + emitDirectReturnTarget, emitAlgReturnTarget, + emitDirectReturnInstr, emitVectoredReturnInstr, + mkRetInfoTable, + mkStdInfoTable, + mkFunGenInfoExtraBits, + entryCode, closureInfoPtr, + getConstrTag, + infoTable, infoTableClosureType, + infoTablePtrs, infoTableNonPtrs, + funInfoTable, + vectorSlot, + ) where + + +#include "HsVersions.h" + +import ClosureInfo ( ClosureInfo, closureTypeDescr, closureName, + infoTableLabelFromCI, Liveness, + closureValDescr, closureSRT, closureSMRep, + closurePtrsSize, closureNonHdrSize, closureFunInfo, + C_SRT(..), needsSRT, isConstrClosure_maybe, + ArgDescr(..) ) +import SMRep ( StgHalfWord, hALF_WORD_SIZE_IN_BITS, hALF_WORD_SIZE, + WordOff, ByteOff, + smRepClosureTypeInt, tablesNextToCode, + rET_BIG, rET_SMALL, rET_VEC_BIG, rET_VEC_SMALL ) +import CgBindery ( getLiveStackSlots ) +import CgCallConv ( isBigLiveness, mkLivenessCLit, buildContLiveness, + argDescrType, getSequelAmode, + CtrlReturnConvention(..) ) +import CgUtils ( mkStringCLit, packHalfWordsCLit, mkWordCLit, + cmmOffsetB, cmmOffsetExprW, cmmLabelOffW, cmmOffsetW, + emitDataLits, emitRODataLits, emitSwitch, cmmNegate ) +import CgMonad + +import CmmUtils ( mkIntCLit, zeroCLit ) +import Cmm ( CmmStmt(..), CmmExpr(..), CmmLit(..), LocalReg, + CmmBasicBlock, nodeReg ) +import MachOp ( MachOp(..), wordRep, halfWordRep ) +import CLabel +import StgSyn ( SRT(..) ) +import Name ( Name ) +import DataCon ( DataCon, dataConTag, fIRST_TAG ) +import Unique ( Uniquable(..) ) +import CmdLineOpts ( opt_SccProfilingOn ) +import ListSetOps ( assocDefault ) +import Maybes ( isJust ) +import Constants ( wORD_SIZE, sIZEOF_StgFunInfoExtra ) +import Outputable + + +------------------------------------------------------------------------- +-- +-- Generating the info table and code for a closure +-- +------------------------------------------------------------------------- + +-- Here we make a concrete info table, represented as a list of CmmAddr +-- (it can't be simply a list of Word, because the SRT field is +-- represented by a label+offset expression). + +-- With tablesNextToCode, the layout is +-- +-- +-- +-- +-- Without tablesNextToCode, the layout of an info table is +-- +-- +-- +-- +-- See includes/InfoTables.h + +emitClosureCodeAndInfoTable :: ClosureInfo -> [LocalReg] -> CgStmts -> Code +emitClosureCodeAndInfoTable cl_info args body + = do { ty_descr_lit <- + if opt_SccProfilingOn + then mkStringCLit (closureTypeDescr cl_info) + else return (mkIntCLit 0) + ; cl_descr_lit <- + if opt_SccProfilingOn + then mkStringCLit cl_descr_string + else return (mkIntCLit 0) + ; let std_info = mkStdInfoTable ty_descr_lit cl_descr_lit + cl_type srt_len layout_lit + + ; blks <- cgStmtsToBlocks body + ; emitInfoTableAndCode info_lbl std_info extra_bits args blks } + where + info_lbl = infoTableLabelFromCI cl_info + + cl_descr_string = closureValDescr cl_info + cl_type = smRepClosureTypeInt (closureSMRep cl_info) + + srt = closureSRT cl_info + needs_srt = needsSRT srt + + mb_con = isConstrClosure_maybe cl_info + is_con = isJust mb_con + + (srt_label,srt_len) + = case mb_con of + Just con -> -- Constructors don't have an SRT + -- We keep the *zero-indexed* tag in the srt_len + -- field of the info table. + (mkIntCLit 0, fromIntegral (dataConTagZ con)) + + Nothing -> -- Not a constructor + srtLabelAndLength srt + + ptrs = closurePtrsSize cl_info + nptrs = size - ptrs + size = closureNonHdrSize cl_info + layout_lit = packHalfWordsCLit ptrs nptrs + + extra_bits + | is_fun = fun_extra_bits + | is_con = [] + | needs_srt = [srt_label] + | otherwise = [] + + maybe_fun_stuff = closureFunInfo cl_info + is_fun = isJust maybe_fun_stuff + (Just (arity, arg_descr)) = maybe_fun_stuff + + fun_extra_bits + | ArgGen liveness <- arg_descr + = [ fun_amode, + srt_label, + mkLivenessCLit liveness, + CmmLabel (mkSlowEntryLabel (closureName cl_info)) ] + | needs_srt = [fun_amode, srt_label] + | otherwise = [fun_amode] + + fun_amode = packHalfWordsCLit fun_type arity + fun_type = argDescrType arg_descr + +-- We keep the *zero-indexed* tag in the srt_len field of the info +-- table of a data constructor. +dataConTagZ :: DataCon -> ConTagZ +dataConTagZ con = dataConTag con - fIRST_TAG + +-- A low-level way to generate the variable part of a fun-style info table. +-- (must match fun_extra_bits above). Used by the C-- parser. +mkFunGenInfoExtraBits :: Int -> Int -> CmmLit -> CmmLit -> CmmLit -> [CmmLit] +mkFunGenInfoExtraBits fun_type arity srt_label liveness slow_entry + = [ packHalfWordsCLit fun_type arity, + srt_label, + liveness, + slow_entry ] + +------------------------------------------------------------------------- +-- +-- Generating the info table and code for a return point +-- +------------------------------------------------------------------------- + +-- Here's the layout of a return-point info table +-- +-- Tables next to code: +-- +-- +-- +-- +-- ret-addr --> +-- +-- Not tables-next-to-code: +-- +-- ret-addr --> +-- +-- +-- +-- +-- * The vector table is only present for vectored returns +-- +-- * The SRT slot is only there if either +-- (a) there is SRT info to record, OR +-- (b) if the return is vectored +-- The latter (b) is necessary so that the vector is in a +-- predictable place + +vectorSlot :: CmmExpr -> CmmExpr -> CmmExpr +-- Get the vector slot from the info pointer +vectorSlot info_amode zero_indexed_tag + | tablesNextToCode + = cmmOffsetExprW (cmmOffsetW info_amode (- (stdInfoTableSizeW + 2))) + (cmmNegate zero_indexed_tag) + -- The "2" is one for the SRT slot, and one more + -- to get to the first word of the vector + + | otherwise + = cmmOffsetExprW (cmmOffsetW info_amode (stdInfoTableSizeW + 2)) + zero_indexed_tag + -- The "2" is one for the entry-code slot and one for the SRT slot + + +emitReturnTarget + :: Name + -> CgStmts -- The direct-return code (if any) + -- (empty for vectored returns) + -> [CLabel] -- Vector of return points + -- (empty for non-vectored returns) + -> SRT + -> FCode CLabel +emitReturnTarget name stmts vector srt + = do { live_slots <- getLiveStackSlots + ; liveness <- buildContLiveness name live_slots + ; srt_info <- getSRTInfo name srt + + ; let + cl_type = case (null vector, isBigLiveness liveness) of + (True, True) -> rET_BIG + (True, False) -> rET_SMALL + (False, True) -> rET_VEC_BIG + (False, False) -> rET_VEC_SMALL + + (std_info, extra_bits) = + mkRetInfoTable liveness srt_info cl_type vector + + ; blks <- cgStmtsToBlocks stmts + ; emitInfoTableAndCode info_lbl std_info extra_bits args blks + ; return info_lbl } + where + args = trace "emitReturnTarget: missing args" [] + uniq = getUnique name + info_lbl = mkReturnInfoLabel uniq + + +mkRetInfoTable + :: Liveness -- liveness + -> C_SRT -- SRT Info + -> Int -- type (eg. rET_SMALL) + -> [CLabel] -- vector + -> ([CmmLit],[CmmLit]) +mkRetInfoTable liveness srt_info cl_type vector + = (std_info, extra_bits) + where + (srt_label, srt_len) = srtLabelAndLength srt_info + + srt_slot | need_srt = [srt_label] + | otherwise = [] + + need_srt = needsSRT srt_info || not (null vector) + -- If there's a vector table then we must allocate + -- an SRT slot, so that the vector table is at a + -- known offset from the info pointer + + liveness_lit = mkLivenessCLit liveness + std_info = mkStdInfoTable zeroCLit zeroCLit cl_type srt_len liveness_lit + extra_bits = srt_slot ++ map CmmLabel vector + + +emitDirectReturnTarget + :: Name + -> CgStmts -- The direct-return code + -> SRT + -> FCode CLabel +emitDirectReturnTarget name code srt + = emitReturnTarget name code [] srt + +emitAlgReturnTarget + :: Name -- Just for its unique + -> [(ConTagZ, CgStmts)] -- Tagged branches + -> Maybe CgStmts -- Default branch (if any) + -> SRT -- Continuation's SRT + -> CtrlReturnConvention + -> FCode (CLabel, SemiTaggingStuff) + +emitAlgReturnTarget name branches mb_deflt srt ret_conv + = case ret_conv of + UnvectoredReturn fam_sz -> do + { blks <- getCgStmts $ + emitSwitch tag_expr branches mb_deflt 0 (fam_sz - 1) + -- NB: tag_expr is zero-based + ; lbl <- emitDirectReturnTarget name blks srt + ; return (lbl, Nothing) } + -- Nothing: the internal branches in the switch don't have + -- global labels, so we can't use them at the 'call site' + + VectoredReturn fam_sz -> do + { tagged_lbls <- mapFCs emit_alt branches + ; deflt_lbl <- emit_deflt mb_deflt + ; let vector = [ assocDefault deflt_lbl tagged_lbls i + | i <- [0..fam_sz-1]] + ; lbl <- emitReturnTarget name noCgStmts vector srt + ; return (lbl, Just (tagged_lbls, deflt_lbl)) } + where + uniq = getUnique name + tag_expr = getConstrTag (CmmReg nodeReg) + + emit_alt :: (Int, CgStmts) -> FCode (Int, CLabel) + -- Emit the code for the alternative as a top-level + -- code block returning a label for it + emit_alt (tag, stmts) = do { let lbl = mkAltLabel uniq tag + ; blks <- cgStmtsToBlocks stmts + ; emitProc [] lbl [] blks + ; return (tag, lbl) } + + emit_deflt (Just stmts) = do { let lbl = mkDefaultLabel uniq + ; blks <- cgStmtsToBlocks stmts + ; emitProc [] lbl [] blks + ; return lbl } + emit_deflt Nothing = return mkErrorStdEntryLabel + -- Nothing case: the simplifier might have eliminated a case + -- so we may have e.g. case xs of + -- [] -> e + -- In that situation the default should never be taken, + -- so we just use mkErrorStdEntryLabel + +-------------------------------- +emitDirectReturnInstr :: Code +emitDirectReturnInstr + = do { info_amode <- getSequelAmode + ; stmtC (CmmJump (entryCode info_amode) []) } + +emitVectoredReturnInstr :: CmmExpr -- *Zero-indexed* constructor tag + -> Code +emitVectoredReturnInstr zero_indexed_tag + = do { info_amode <- getSequelAmode + ; let slot = vectorSlot info_amode zero_indexed_tag + ; stmtC (CmmJump (CmmLoad slot wordRep) []) } + + + +------------------------------------------------------------------------- +-- +-- Generating a standard info table +-- +------------------------------------------------------------------------- + +-- The standard bits of an info table. This part of the info table +-- corresponds to the StgInfoTable type defined in InfoTables.h. +-- +-- Its shape varies with ticky/profiling/tables next to code etc +-- so we can't use constant offsets from Constants + +mkStdInfoTable + :: CmmLit -- closure type descr (profiling) + -> CmmLit -- closure descr (profiling) + -> Int -- closure type + -> StgHalfWord -- SRT length + -> CmmLit -- layout field + -> [CmmLit] + +mkStdInfoTable type_descr closure_descr cl_type srt_len layout_lit + = -- Parallel revertible-black hole field + prof_info + -- Ticky info (none at present) + -- Debug info (none at present) + ++ [layout_lit, type_lit] + + where + prof_info + | opt_SccProfilingOn = [closure_descr, type_descr] + | otherwise = [] + + type_lit = packHalfWordsCLit cl_type srt_len + +stdInfoTableSizeW :: WordOff +-- The size of a standard info table varies with profiling/ticky etc, +-- so we can't get it from Constants +-- It must vary in sync with mkStdInfoTable +stdInfoTableSizeW + = size_fixed + size_prof + where + size_fixed = 2 -- layout, type + size_prof | opt_SccProfilingOn = 2 + | otherwise = 0 + +stdInfoTableSizeB = stdInfoTableSizeW * wORD_SIZE :: ByteOff + +stdSrtBitmapOffset :: ByteOff +-- Byte offset of the SRT bitmap half-word which is +-- in the *higher-addressed* part of the type_lit +stdSrtBitmapOffset = stdInfoTableSizeB - hALF_WORD_SIZE + +stdClosureTypeOffset :: ByteOff +-- Byte offset of the closure type half-word +stdClosureTypeOffset = stdInfoTableSizeB - wORD_SIZE + +stdPtrsOffset, stdNonPtrsOffset :: ByteOff +stdPtrsOffset = stdInfoTableSizeB - 2*wORD_SIZE +stdNonPtrsOffset = stdInfoTableSizeB - 2*wORD_SIZE + hALF_WORD_SIZE + +------------------------------------------------------------------------- +-- +-- Accessing fields of an info table +-- +------------------------------------------------------------------------- + +closureInfoPtr :: CmmExpr -> CmmExpr +-- Takes a closure pointer and returns the info table pointer +closureInfoPtr e = CmmLoad e wordRep + +entryCode :: CmmExpr -> CmmExpr +-- Takes an info pointer (the first word of a closure) +-- and returns its entry code +entryCode e | tablesNextToCode = e + | otherwise = CmmLoad e wordRep + +getConstrTag :: CmmExpr -> CmmExpr +-- Takes a closure pointer, and return the *zero-indexed* +-- constructor tag obtained from the info table +-- This lives in the SRT field of the info table +-- (constructors don't need SRTs). +getConstrTag closure_ptr + = CmmMachOp (MO_U_Conv halfWordRep wordRep) [infoTableConstrTag info_table] + where + info_table = infoTable (closureInfoPtr closure_ptr) + +infoTable :: CmmExpr -> CmmExpr +-- Takes an info pointer (the first word of a closure) +-- and returns a pointer to the first word of the standard-form +-- info table, excluding the entry-code word (if present) +infoTable info_ptr + | tablesNextToCode = cmmOffsetB info_ptr (- stdInfoTableSizeB) + | otherwise = cmmOffsetW info_ptr 1 -- Past the entry code pointer + +infoTableConstrTag :: CmmExpr -> CmmExpr +-- Takes an info table pointer (from infoTable) and returns the constr tag +-- field of the info table (same as the srt_bitmap field) +infoTableConstrTag = infoTableSrtBitmap + +infoTableSrtBitmap :: CmmExpr -> CmmExpr +-- Takes an info table pointer (from infoTable) and returns the srt_bitmap +-- field of the info table +infoTableSrtBitmap info_tbl + = CmmLoad (cmmOffsetB info_tbl stdSrtBitmapOffset) halfWordRep + +infoTableClosureType :: CmmExpr -> CmmExpr +-- Takes an info table pointer (from infoTable) and returns the closure type +-- field of the info table. +infoTableClosureType info_tbl + = CmmLoad (cmmOffsetB info_tbl stdClosureTypeOffset) halfWordRep + +infoTablePtrs :: CmmExpr -> CmmExpr +infoTablePtrs info_tbl + = CmmLoad (cmmOffsetB info_tbl stdPtrsOffset) halfWordRep + +infoTableNonPtrs :: CmmExpr -> CmmExpr +infoTableNonPtrs info_tbl + = CmmLoad (cmmOffsetB info_tbl stdNonPtrsOffset) halfWordRep + +funInfoTable :: CmmExpr -> CmmExpr +-- Takes the info pointer of a function, +-- and returns a pointer to the first word of the StgFunInfoExtra struct +-- in the info table. +funInfoTable info_ptr + | tablesNextToCode + = cmmOffsetB info_ptr (- stdInfoTableSizeB - sIZEOF_StgFunInfoExtra) + | otherwise + = cmmOffsetW info_ptr (1 + stdInfoTableSizeW) + -- Past the entry code pointer + +------------------------------------------------------------------------- +-- +-- Emit the code for a closure (or return address) +-- and its associated info table +-- +------------------------------------------------------------------------- + +-- The complication here concerns whether or not we can +-- put the info table next to the code + +emitInfoTableAndCode + :: CLabel -- Label of info table + -> [CmmLit] -- ...its invariant part + -> [CmmLit] -- ...and its variant part + -> [LocalReg] -- ...args + -> [CmmBasicBlock] -- ...and body + -> Code + +emitInfoTableAndCode info_lbl std_info extra_bits args blocks + | tablesNextToCode -- Reverse the extra_bits; and emit the top-level proc + = emitProc (reverse extra_bits ++ std_info) + entry_lbl args blocks + -- NB: the info_lbl is discarded + + | null blocks -- No actual code; only the info table is significant + = -- Use a zero place-holder in place of the + -- entry-label in the info table + emitRODataLits info_lbl (zeroCLit : std_info ++ extra_bits) + + | otherwise -- Separately emit info table (with the function entry + = -- point as first entry) and the entry code + do { emitDataLits info_lbl (CmmLabel entry_lbl : std_info ++ extra_bits) + ; emitProc [] entry_lbl args blocks } + + where + entry_lbl = infoLblToEntryLbl info_lbl + +------------------------------------------------------------------------- +-- +-- Static reference tables +-- +------------------------------------------------------------------------- + +-- There is just one SRT for each top level binding; all the nested +-- bindings use sub-sections of this SRT. The label is passed down to +-- the nested bindings via the monad. + +getSRTInfo :: Name -> SRT -> FCode C_SRT +getSRTInfo id NoSRT = return NoC_SRT +getSRTInfo id (SRT off len bmp) + | len > hALF_WORD_SIZE_IN_BITS || bmp == [fromIntegral srt_escape] + = do { srt_lbl <- getSRTLabel + ; let srt_desc_lbl = mkSRTDescLabel id + ; emitRODataLits srt_desc_lbl + ( cmmLabelOffW srt_lbl off + : mkWordCLit (fromIntegral len) + : map mkWordCLit bmp) + ; return (C_SRT srt_desc_lbl 0 srt_escape) } + + | otherwise + = do { srt_lbl <- getSRTLabel + ; return (C_SRT srt_lbl off (fromIntegral (head bmp))) } + -- The fromIntegral converts to StgHalfWord + +srt_escape = (-1) :: StgHalfWord + +srtLabelAndLength :: C_SRT -> (CmmLit, StgHalfWord) +srtLabelAndLength NoC_SRT = (zeroCLit, 0) +srtLabelAndLength (C_SRT lbl off bitmap) = (cmmLabelOffW lbl off, bitmap) + diff --git a/ghc/compiler/codeGen/CgLetNoEscape.lhs b/ghc/compiler/codeGen/CgLetNoEscape.lhs index 80b80ee6b2..3ea05974f6 100644 --- a/ghc/compiler/codeGen/CgLetNoEscape.lhs +++ b/ghc/compiler/codeGen/CgLetNoEscape.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 % -% $Id: CgLetNoEscape.lhs,v 1.24 2003/07/21 11:01:07 simonmar Exp $ +% $Id: CgLetNoEscape.lhs,v 1.25 2004/08/13 13:06:03 simonmar Exp $ % %******************************************************** %* * @@ -18,21 +18,23 @@ import {-# SOURCE #-} CgExpr ( cgExpr ) import StgSyn import CgMonad -import AbsCSyn import CgBindery ( CgIdInfo, letNoEscapeIdInfo, nukeDeadBindings ) -import CgCase ( mkRetDirectTarget, restoreCurrentCostCentre ) +import CgCase ( restoreCurrentCostCentre ) import CgCon ( bindUnboxedTupleComponents ) import CgHeapery ( unbxTupleHeapCheck ) -import CgStackery ( allocStackTop, deAllocStackTop ) -import CgUsages ( getSpRelOffset ) +import CgInfoTbls ( emitDirectReturnTarget ) +import CgStackery ( allocStackTop, deAllocStackTop, getSpRelOffset ) +import Cmm ( CmmStmt(..) ) +import CmmUtils ( mkLblExpr, oneStmt ) import CLabel ( mkReturnInfoLabel ) import ClosureInfo ( mkLFLetNoEscape ) import CostCentre ( CostCentreStack ) -import Id ( Id ) +import Id ( Id, idName ) import Var ( idUnique ) -import PrimRep ( PrimRep(..), retPrimRepSize ) +import SMRep ( retAddrSizeW ) import BasicTypes ( RecFlag(..) ) +import Outputable \end{code} %************************************************************************ @@ -156,25 +158,23 @@ cgLetNoEscapeClosure arity = length args lf_info = mkLFLetNoEscape arity in - -- saveVolatileVarsAndRegs done earlier in cgExpr. - forkEvalHelp - rhs_eob_info + do { (vSp, _) <- forkEvalHelp rhs_eob_info + + (do { allocStackTop retAddrSizeW + ; nukeDeadBindings full_live_in_rhss }) - (allocStackTop retPrimRepSize `thenFC` \_ -> - nukeDeadBindings full_live_in_rhss) + (do { deAllocStackTop retAddrSizeW + ; abs_c <- forkProc $ cgLetNoEscapeBody bndr cc + cc_slot args body - (deAllocStackTop retPrimRepSize `thenFC` \_ -> - forkAbsC ( - cgLetNoEscapeBody bndr cc cc_slot args body - ) `thenFC` \ abs_c -> - mkRetDirectTarget bndr abs_c srt - -- Ignore the label that comes back from - -- mkRetDirectTarget. It must be conjured up elswhere - ) `thenFC` \ (vSp, _) -> + -- Ignore the label that comes back from + -- mkRetDirectTarget. It must be conjured up elswhere + ; emitDirectReturnTarget (idName bndr) abs_c srt + ; return () }) - returnFC (bndr, letNoEscapeIdInfo bndr vSp lf_info) + ; returnFC (bndr, letNoEscapeIdInfo bndr vSp lf_info) } \end{code} \begin{code} @@ -185,28 +185,28 @@ cgLetNoEscapeBody :: Id -- Name of the joint point -> StgExpr -- Body -> Code -cgLetNoEscapeBody bndr cc cc_slot all_args body - = bindUnboxedTupleComponents all_args `thenFC` \ (arg_regs, ptrs, nptrs, ret_slot) -> +cgLetNoEscapeBody bndr cc cc_slot all_args body = do + { (arg_regs, ptrs, nptrs, ret_slot) <- bindUnboxedTupleComponents all_args -- restore the saved cost centre. BUT: we must not free the stack slot -- containing the cost centre, because it might be needed for a -- recursive call to this let-no-escape. - restoreCurrentCostCentre cc_slot False{-don't free-} `thenC` + ; restoreCurrentCostCentre cc_slot False{-don't free-} -- Enter the closures cc, if required - --enterCostCentreCode closure_info cc IsFunction `thenC` + ; -- enterCostCentreCode closure_info cc IsFunction -- The "return address" slot doesn't have a return address in it; -- but the heap-check needs it filled in if the heap-check fails. -- So we pass code to fill it in to the heap-check macro - getSpRelOffset ret_slot `thenFC` \ sp_rel -> - let lbl = mkReturnInfoLabel (idUnique bndr) - frame_hdr_asst = CAssign (CVal sp_rel RetRep) (CLbl lbl RetRep) - in + ; sp_rel <- getSpRelOffset ret_slot + + ; let lbl = mkReturnInfoLabel (idUnique bndr) + frame_hdr_asst = oneStmt (CmmStore sp_rel (mkLblExpr lbl)) -- Do heap check [ToDo: omit for non-recursive case by recording in -- in envt and absorbing at call site] - unbxTupleHeapCheck arg_regs ptrs nptrs frame_hdr_asst ( - cgExpr body - ) + ; unbxTupleHeapCheck arg_regs ptrs nptrs frame_hdr_asst + (cgExpr body) + } \end{code} diff --git a/ghc/compiler/codeGen/CgMonad.lhs b/ghc/compiler/codeGen/CgMonad.lhs index 88083f7536..003be9701c 100644 --- a/ghc/compiler/codeGen/CgMonad.lhs +++ b/ghc/compiler/codeGen/CgMonad.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgMonad.lhs,v 1.39 2003/07/02 13:12:38 simonpj Exp $ +% $Id: CgMonad.lhs,v 1.40 2004/08/13 13:06:03 simonmar Exp $ % \section[CgMonad]{The code generation monad} @@ -14,56 +14,64 @@ module CgMonad ( FCode, -- type initC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs, - returnFC, fixC, absC, nopC, getAbsC, + returnFC, fixC, checkedAbsC, + stmtC, stmtsC, labelC, emitStmts, nopC, whenC, newLabelC, + newUnique, newUniqSupply, + CgStmts, emitCgStmts, forkCgStmts, cgStmtsToBlocks, + getCgStmts', getCgStmts, + noCgStmts, oneCgStmt, consCgStmt, + + getCmm, + emitData, emitProc, emitSimpleProc, + + forkLabelledCode, forkClosureBody, forkStatics, forkAlts, forkEval, - forkEvalHelp, forkAbsC, - SemiTaggingStuff, + forkEvalHelp, forkProc, codeOnly, + SemiTaggingStuff, ConTagZ, EndOfBlockInfo(..), setEndOfBlockInfo, getEndOfBlockInfo, - setSRTLabel, getSRTLabel, getSRTInfo, + setSRTLabel, getSRTLabel, setTickyCtrLabel, getTickyCtrLabel, - StackUsage, Slot(..), HeapUsage, - - profCtrC, profCtrAbsC, ldvEnter, + StackUsage(..), HeapUsage(..), + VirtualSpOffset, VirtualHpOffset, + initStkUsage, initHpUsage, + getHpUsage, setHpUsage, + heapHWM, - costCentresC, moduleName, + moduleName, Sequel(..), -- ToDo: unabstract? - sequelToAmode, -- ideally we wouldn't export these, but some other modules access internal state getState, setState, getInfoDown, -- more localised access to monad state - getUsage, setUsage, + getStkUsage, setStkUsage, getBinds, setBinds, getStaticBinds, -- out of general friendliness, we also export ... - CgInfoDownwards(..), CgState(..), -- non-abstract - CompilationInfo(..) + CgInfoDownwards(..), CgState(..) -- non-abstract ) where #include "HsVersions.h" import {-# SOURCE #-} CgBindery ( CgBindings, nukeVolatileBinds ) -import {-# SOURCE #-} CgUsages ( getSpRelOffset ) -import AbsCSyn +import Cmm +import CmmUtils ( CmmStmts, isNopStmt ) import CLabel -import StgSyn ( SRT(..) ) -import AbsCUtils ( mkAbsCStmts ) -import CmdLineOpts ( opt_SccProfilingOn, opt_DoTickyProfiling ) +import SMRep ( WordOff ) import Module ( Module ) -import DataCon ( ConTag ) import Id ( Id ) -import Name ( Name ) import VarEnv -import PrimRep ( PrimRep(..) ) -import SMRep ( StgHalfWord, hALF_WORD ) +import OrdList +import Unique ( Unique ) +import Util ( mapAccumL ) +import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply, uniqFromSupply ) import FastString import Outputable @@ -83,29 +91,46 @@ along. \begin{code} data CgInfoDownwards -- information only passed *downwards* by the monad - = MkCgInfoDown - CompilationInfo -- COMPLETELY STATIC info about this compilation - -- (e.g., what flags were passed to the compiler) - - CgBindings -- [Id -> info] : static environment - - CLabel -- label of the current SRT - - CLabel -- current destination for ticky counts - - EndOfBlockInfo -- Info for stuff to do at end of basic block: - - -data CompilationInfo - = MkCompInfo - Module -- the module name + = MkCgInfoDown { + cgd_mod :: Module, -- Module being compiled + cgd_statics :: CgBindings, -- [Id -> info] : static environment + cgd_srt :: CLabel, -- label of the current SRT + cgd_ticky :: CLabel, -- current destination for ticky counts + cgd_eob :: EndOfBlockInfo -- Info for stuff to do at end of basic block: + } + +initCgInfoDown :: Module -> CgInfoDownwards +initCgInfoDown mod + = MkCgInfoDown { cgd_mod = mod, + cgd_statics = emptyVarEnv, + cgd_srt = error "initC: srt", + cgd_ticky = mkTopTickyCtrLabel, + cgd_eob = initEobInfo } data CgState - = MkCgState - AbstractC -- code accumulated so far - CgBindings -- [Id -> info] : *local* bindings environment - -- Bindings for top-level things are given in the info-down part - CgStksAndHeapUsage + = MkCgState { + cgs_stmts :: OrdList CgStmt, -- Current proc + cgs_tops :: OrdList CmmTop, + -- Other procedures and data blocks in this compilation unit + -- Both the latter two are ordered only so that we can + -- reduce forward references, when it's easy to do so + + cgs_binds :: CgBindings, -- [Id -> info] : *local* bindings environment + -- Bindings for top-level things are given in + -- the info-down part + + cgs_stk_usg :: StackUsage, + cgs_hp_usg :: HeapUsage, + + cgs_uniqs :: UniqSupply } + +initCgState :: UniqSupply -> CgState +initCgState uniqs + = MkCgState { cgs_stmts = nilOL, cgs_tops = nilOL, + cgs_binds = emptyVarEnv, + cgs_stk_usg = initStkUsage, + cgs_hp_usg = initHpUsage, + cgs_uniqs = uniqs } \end{code} @EndOfBlockInfo@ tells what to do at the end of this block of code or, @@ -123,7 +148,7 @@ data EndOfBlockInfo -- by a case alternative. Sequel -initEobInfo = EndOfBlockInfo 0 (OnStack 0) +initEobInfo = EndOfBlockInfo 0 OnStack \end{code} Any addressing modes inside @Sequel@ must be ``robust,'' in the sense @@ -132,105 +157,164 @@ block. \begin{code} data Sequel - = OnStack - VirtualSpOffset -- Continuation is on the stack, at the - -- specified location - - | UpdateCode + = OnStack -- Continuation is on the stack + | UpdateCode -- Continuation is update | CaseAlts - CAddrMode -- Jump to this; if the continuation is for a vectored - -- case this might be the label of a return - -- vector Guaranteed to be a non-volatile - -- addressing mode (I think) + CLabel -- Jump to this; if the continuation is for a vectored + -- case this might be the label of a return vector SemiTaggingStuff - + Id -- The case binder, only used to see if it's dead Bool -- True <=> polymorphic, push a SEQ frame too - type SemiTaggingStuff - = Maybe -- Maybe[1] we don't have any semi-tagging stuff... - ([(ConTag, JoinDetails)], -- Alternatives - Maybe (Id, JoinDetails) -- Default (but Maybe[2] we don't have one) - -- The default branch expects a - -- it expects a ptr to the thing - -- in Node, bound to b - ) - -type JoinDetails - = (AbstractC, CLabel) -- Code to load regs from heap object + profiling macros, - -- and join point label - --- The abstract C is executed only from a successful semitagging + = Maybe -- Maybe[1] we don't have any semi-tagging stuff... + ([(ConTagZ, CLabel)], -- Alternatives + CLabel) -- Default (will be a can't happen RTS label if can't happen) + +type ConTagZ = Int -- A *zero-indexed* contructor tag + +-- The case branch is executed only from a successful semitagging -- venture, when a case has looked at a variable, found that it's -- evaluated, and wants to load up the contents and go to the join -- point. +\end{code} + +%************************************************************************ +%* * + CgStmt type +%* * +%************************************************************************ + +The CgStmts type is what the code generator outputs: it is a tree of +statements, including in-line labels. The job of flattenCgStmts is to +turn this into a list of basic blocks, each of which ends in a jump +statement (either a local branch or a non-local jump). + +\begin{code} +type CgStmts = OrdList CgStmt + +data CgStmt + = CgStmt CmmStmt + | CgLabel BlockId + | CgFork BlockId CgStmts + +flattenCgStmts :: BlockId -> CgStmts -> [CmmBasicBlock] +flattenCgStmts id stmts = + case flatten (fromOL stmts) of + ([],blocks) -> blocks + (block,blocks) -> BasicBlock id block : blocks + where + flatten [] = ([],[]) + + -- A label at the end of a function or fork: this label must not be reachable, + -- but it might be referred to from another BB that also isn't reachable. + -- Eliminating these has to be done with a dead-code analysis. For now, + -- we just make it into a well-formed block by adding a recursive jump. + flatten [CgLabel id] + = ( [], [BasicBlock id [CmmBranch id]] ) + + -- A jump/branch: throw away all the code up to the next label, because + -- it is unreachable. Be careful to keep forks that we find on the way. + flatten (CgStmt stmt : stmts) + | isJump stmt + = case dropWhile isOrdinaryStmt stmts of + [] -> ( [stmt], [] ) + [CgLabel id] -> ( [stmt], [BasicBlock id [CmmBranch id]]) + (CgLabel id : stmts) -> ( [stmt], BasicBlock id block : blocks ) + where (block,blocks) = flatten stmts + (CgFork fork_id stmts : ss) -> + flatten (CgFork fork_id stmts : CgStmt stmt : ss) + + flatten (s:ss) = + case s of + CgStmt stmt -> (stmt:block,blocks) + CgLabel id -> ([CmmBranch id],BasicBlock id block:blocks) + CgFork fork_id stmts -> + (block, BasicBlock fork_id fork_block : fork_blocks ++ blocks) + where (fork_block, fork_blocks) = flatten (fromOL stmts) + where (block,blocks) = flatten ss + +isJump (CmmJump _ _) = True +isJump (CmmBranch _) = True +isJump _ = False + +isOrdinaryStmt (CgStmt _) = True +isOrdinaryStmt _ = False +\end{code} + +%************************************************************************ +%* * + Stack and heap models +%* * +%************************************************************************ --- 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. - --- sequelToAmode returns an amode which refers to an info table. The info --- table will always be of the RET(_VEC)?_(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. - -sequelToAmode :: Sequel -> FCode CAddrMode - -sequelToAmode (OnStack virt_sp_offset) - = getSpRelOffset virt_sp_offset `thenFC` \ sp_rel -> - returnFC (CVal sp_rel RetRep) - -sequelToAmode UpdateCode = returnFC (CLbl mkUpdInfoLabel RetRep) - -sequelToAmode (CaseAlts amode _ False) = returnFC amode -sequelToAmode (CaseAlts amode _ True) = returnFC (CLbl mkSeqInfoLabel RetRep) - -type CgStksAndHeapUsage -- stacks and heap usage information - = (StackUsage, HeapUsage) - -data Slot = Free | NonPointer - deriving -#ifdef DEBUG - (Eq,Show) -#else - Eq -#endif - -type StackUsage = - (Int, -- virtSp: Virtual offset of topmost allocated slot - Int, -- frameSp: End of the current stack frame - [(Int,Slot)], -- free: List of free slots, in increasing order - Int, -- realSp: Virtual offset of real stack pointer - Int) -- hwSp: Highest value ever taken by virtSp - --- ToDo (SDM, 7 Jan 2003): I'm not sure that the distinction between --- Free and NonPointer in the free list is needed any more. It used --- to be needed because we constructed bitmaps from the free list, but --- now we construct bitmaps by finding all the live pointer bindings --- instead. Non-pointer stack slots (i.e. saved cost centres) can --- just be removed from the free list instead of being recorded as a --- NonPointer. - -type HeapUsage = - (HeapOffset, -- virtHp: Virtual offset of highest-allocated word - HeapOffset) -- realHp: Virtual offset of real heap ptr +\begin{code} +type VirtualHpOffset = WordOff -- Both are in +type VirtualSpOffset = WordOff -- units of words + +data StackUsage + = StackUsage { + virtSp :: VirtualSpOffset, + -- Virtual offset of topmost allocated slot + + frameSp :: VirtualSpOffset, + -- Virtual offset of the return address of the enclosing frame. + -- This RA describes the liveness/pointedness of + -- all the stack from frameSp downwards + -- INVARIANT: less than or equal to virtSp + + freeStk :: [VirtualSpOffset], + -- List of free slots, in *increasing* order + -- INVARIANT: all <= virtSp + -- All slots <= virtSp are taken except these ones + + realSp :: VirtualSpOffset, + -- Virtual offset of real stack pointer register + + hwSp :: VirtualSpOffset + } -- Highest value ever taken by virtSp + +-- INVARAINT: The environment contains no Stable references to +-- stack slots below (lower offset) frameSp +-- It can contain volatile references to this area though. + +data HeapUsage = + HeapUsage { + virtHp :: VirtualHpOffset, -- Virtual offset of highest-allocated word + realHp :: VirtualHpOffset -- realHp: Virtual offset of real heap ptr + } \end{code} -NB: absolutely every one of the above Ints is really -a VirtualOffset of some description (the code generator -works entirely in terms of VirtualOffsets). +The heap high water mark is the larger of virtHp and hwHp. The latter is +only records the high water marks of forked-off branches, so to find the +heap high water mark you have to take the max of virtHp and hwHp. Remember, +virtHp never retreats! -Initialisation. +Note Jan 04: ok, so why do we only look at the virtual Hp?? \begin{code} -initialStateC = MkCgState AbsCNop emptyVarEnv initUsage +heapHWM :: HeapUsage -> VirtualHpOffset +heapHWM = virtHp +\end{code} -initUsage :: CgStksAndHeapUsage -initUsage = ((0,0,[],0,0), (0,0)) +Initialisation. + +\begin{code} +initStkUsage :: StackUsage +initStkUsage = StackUsage { + virtSp = 0, + frameSp = 0, + freeStk = [], + realSp = 0, + hwSp = 0 + } + +initHpUsage :: HeapUsage +initHpUsage = HeapUsage { + virtHp = 0, + realHp = 0 + } \end{code} @stateIncUsage@$~e_1~e_2$ incorporates in $e_1$ the stack and heap high water @@ -238,24 +322,42 @@ marks found in $e_2$. \begin{code} stateIncUsage :: CgState -> CgState -> CgState +stateIncUsage s1 s2@(MkCgState { cgs_stk_usg = stk_usg, cgs_hp_usg = hp_usg }) + = s1 { cgs_hp_usg = cgs_hp_usg s1 `maxHpHw` virtHp hp_usg, + cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp stk_usg } + `addCodeBlocksFrom` s2 + +stateIncUsageEval :: CgState -> CgState -> CgState +stateIncUsageEval s1 s2 + = s1 { cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp (cgs_stk_usg s2) } + `addCodeBlocksFrom` s2 + -- We don't max the heap high-watermark because stateIncUsageEval is + -- used only in forkEval, which in turn is only used for blocks of code + -- which do their own heap-check. -stateIncUsage (MkCgState abs_c bs ((v,t,f,r,h1),(vH1,rH1))) - (MkCgState _ _ ((_,_,_,_,h2),(vH2, _))) - = MkCgState abs_c - bs - ((v,t,f,r,h1 `max` h2), - (vH1 `max` vH2, rH1)) +addCodeBlocksFrom :: CgState -> CgState -> CgState +-- Add code blocks from the latter to the former +-- (The cgs_stmts will often be empty, but not always; see codeOnly) +s1 `addCodeBlocksFrom` s2 + = s1 { cgs_stmts = cgs_stmts s1 `appOL` cgs_stmts s2, + cgs_tops = cgs_tops s1 `appOL` cgs_tops s2 } + +maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage +hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw } + +maxStkHw :: StackUsage -> VirtualSpOffset -> StackUsage +stk_usg `maxStkHw` hw = stk_usg { hwSp = hwSp stk_usg `max` hw } \end{code} %************************************************************************ %* * -\subsection[CgMonad-basics]{Basic code-generation monad magic} + The FCode monad %* * %************************************************************************ \begin{code} newtype FCode a = FCode (CgInfoDownwards -> CgState -> (a, CgState)) -type Code = FCode () +type Code = FCode () instance Monad FCode where (>>=) = thenFC @@ -268,17 +370,13 @@ instance Monad FCode where The Abstract~C is not in the environment so as to improve strictness. \begin{code} -initC :: CompilationInfo -> Code -> AbstractC - -initC cg_info (FCode code) - = case (code (MkCgInfoDown - cg_info - emptyVarEnv -- (error "initC: statics") - (error "initC: srt") - (mkTopTickyCtrLabel) - initEobInfo) - initialStateC) of - ((),MkCgState abc _ _) -> abc +initC :: Module -> FCode a -> IO a + +initC mod (FCode code) + = do { uniqs <- mkSplitUniqSupply 'c' + ; case code (initCgInfoDown mod) (initCgState uniqs) of + (res, _) -> return res + } returnFC :: a -> FCode a returnFC val = FCode (\info_down state -> (val, state)) @@ -332,9 +430,12 @@ fixC fcode = FCode ( ) \end{code} -Operators for getting and setting the state and "info_down". -To maximise encapsulation, code should try to only get and set the -state it actually uses. +%************************************************************************ +%* * + Operators for getting and setting the state and "info_down". + +%* * +%************************************************************************ \begin{code} getState :: FCode CgState @@ -343,35 +444,58 @@ getState = FCode $ \info_down state -> (state,state) setState :: CgState -> FCode () setState state = FCode $ \info_down _ -> ((),state) -getUsage :: FCode CgStksAndHeapUsage -getUsage = do - MkCgState absC binds usage <- getState - return usage +getStkUsage :: FCode StackUsage +getStkUsage = do + state <- getState + return $ cgs_stk_usg state -setUsage :: CgStksAndHeapUsage -> FCode () -setUsage newusage = do - MkCgState absC binds usage <- getState - setState $ MkCgState absC binds newusage +setStkUsage :: StackUsage -> Code +setStkUsage new_stk_usg = do + state <- getState + setState $ state {cgs_stk_usg = new_stk_usg} + +getHpUsage :: FCode HeapUsage +getHpUsage = do + state <- getState + return $ cgs_hp_usg state + +setHpUsage :: HeapUsage -> Code +setHpUsage new_hp_usg = do + state <- getState + setState $ state {cgs_hp_usg = new_hp_usg} getBinds :: FCode CgBindings getBinds = do - MkCgState absC binds usage <- getState - return binds + state <- getState + return $ cgs_binds state setBinds :: CgBindings -> FCode () -setBinds newbinds = do - MkCgState absC binds usage <- getState - setState $ MkCgState absC newbinds usage +setBinds new_binds = do + state <- getState + setState $ state {cgs_binds = new_binds} getStaticBinds :: FCode CgBindings getStaticBinds = do - (MkCgInfoDown _ static_binds _ _ _) <- getInfoDown - return static_binds + info <- getInfoDown + return (cgd_statics info) withState :: FCode a -> CgState -> FCode (a,CgState) withState (FCode fcode) newstate = FCode $ \info_down state -> let (retval, state2) = fcode info_down newstate in ((retval,state2), state) +newUniqSupply :: FCode UniqSupply +newUniqSupply = do + state <- getState + let (us1, us2) = splitUniqSupply (cgs_uniqs state) + setState $ state { cgs_uniqs = us1 } + return us2 + +newUnique :: FCode Unique +newUnique = do + us <- newUniqSupply + return (uniqFromSupply us) + +------------------ getInfoDown :: FCode CgInfoDownwards getInfoDown = FCode $ \info_down state -> (info_down,state) @@ -383,16 +507,22 @@ doFCode (FCode fcode) info_down state = fcode info_down state \end{code} +%************************************************************************ +%* * + Forking +%* * +%************************************************************************ + @forkClosureBody@ takes a code, $c$, and compiles it in a completely fresh environment, except that: - compilation info and statics are passed in unchanged. The current environment is passed on completely unaltered, except that abstract C from the fork is incorporated. -@forkAbsC@ takes a code and compiles it in the current environment, -returning the abstract C thus constructed. The current environment -is passed on completely unchanged. It is pretty similar to @getAbsC@, -except that the latter does affect the environment. ToDo: combine? +@forkProc@ takes a code and compiles it in the current environment, +returning the basic blocks thus constructed. The current environment +is passed on completely unchanged. It is pretty similar to +@getBlocks@, except that the latter does affect the environment. @forkStatics@ $fc$ compiles $fc$ in an environment whose statics come from the current bindings, but which is otherwise freshly initialised. @@ -401,40 +531,57 @@ bindings and usage information is otherwise unchanged. \begin{code} forkClosureBody :: Code -> Code - -forkClosureBody (FCode code) = do - (MkCgInfoDown cg_info statics srt ticky _) <- getInfoDown - (MkCgState absC_in binds un_usage) <- getState - let body_info_down = MkCgInfoDown cg_info statics srt ticky initEobInfo - let ((),fork_state) = code body_info_down initialStateC - let MkCgState absC_fork _ _ = fork_state - setState $ MkCgState (AbsCStmts absC_in absC_fork) binds un_usage +forkClosureBody body_code + = do { info <- getInfoDown + ; us <- newUniqSupply + ; state <- getState + ; let body_info_down = info { cgd_eob = initEobInfo } + ((),fork_state) = doFCode body_code body_info_down + (initCgState us) + ; ASSERT( isNilOL (cgs_stmts fork_state) ) + setState $ state `addCodeBlocksFrom` fork_state } forkStatics :: FCode a -> FCode a - -forkStatics (FCode fcode) = FCode ( - \(MkCgInfoDown cg_info _ srt ticky _) - (MkCgState absC_in statics un_usage) - -> - let - (result, state) = fcode rhs_info_down initialStateC - MkCgState absC_fork _ _ = state -- Don't merge these this line with the one - -- above or it becomes too strict! - rhs_info_down = MkCgInfoDown cg_info statics srt ticky initEobInfo - in - (result, MkCgState (AbsCStmts absC_in absC_fork) statics un_usage) - ) - -forkAbsC :: Code -> FCode AbstractC -forkAbsC (FCode code) = - do - info_down <- getInfoDown - (MkCgState absC1 bs usage) <- getState - let ((),MkCgState absC2 _ ((_, _, _, _,h2), _)) = code info_down (MkCgState AbsCNop bs usage) - let ((v, t, f, r, h1), heap_usage) = usage - let new_usage = ((v, t, f, r, h1 `max` h2), heap_usage) - setState $ MkCgState absC1 bs new_usage - return absC2 +forkStatics body_code + = do { info <- getInfoDown + ; us <- newUniqSupply + ; state <- getState + ; let rhs_info_down = info { cgd_statics = cgs_binds state, + cgd_eob = initEobInfo } + (result, fork_state_out) = doFCode body_code rhs_info_down + (initCgState us) + ; ASSERT( isNilOL (cgs_stmts fork_state_out) ) + setState (state `addCodeBlocksFrom` fork_state_out) + ; return result } + +forkProc :: Code -> FCode CgStmts +forkProc body_code + = do { info_down <- getInfoDown + ; us <- newUniqSupply + ; state <- getState + ; let fork_state_in = (initCgState us) + { cgs_binds = cgs_binds state, + cgs_stk_usg = cgs_stk_usg state, + cgs_hp_usg = cgs_hp_usg state } + -- ToDo: is the hp usage necesary? + (code_blks, fork_state_out) = doFCode (getCgStmts body_code) + info_down fork_state_in + ; setState $ state `stateIncUsageEval` fork_state_out + ; return code_blks } + +codeOnly :: Code -> Code +-- Emit any code from the inner thing into the outer thing +-- Do not affect anything else in the outer state +-- Used in almost-circular code to prevent false loop dependencies +codeOnly body_code + = do { info_down <- getInfoDown + ; us <- newUniqSupply + ; state <- getState + ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state, + cgs_stk_usg = cgs_stk_usg state, + cgs_hp_usg = cgs_hp_usg state } + ((), fork_state_out) = doFCode body_code info_down fork_state_in + ; setState $ state `addCodeBlocksFrom` fork_state_out } \end{code} @forkAlts@ $bs~d$ takes fcodes $bs$ for the branches of a @case@, and @@ -448,13 +595,23 @@ that forkAlts :: [FCode a] -> FCode [a] forkAlts branch_fcodes - = do info_down <- getInfoDown - in_state <- getState - let compile (FCode fc) = fc info_down in_state - let (branch_results, branch_out_states) = unzip (map compile branch_fcodes) - setState $ foldl stateIncUsage in_state branch_out_states - -- NB foldl. in_state is the *left* argument to stateIncUsage - return branch_results + = do { info_down <- getInfoDown + ; us <- newUniqSupply + ; state <- getState + ; let compile us branch + = (us2, doFCode branch info_down branch_state) + where + (us1,us2) = splitUniqSupply us + branch_state = (initCgState us1) { + cgs_binds = cgs_binds state, + cgs_stk_usg = cgs_stk_usg state, + cgs_hp_usg = cgs_hp_usg state } + + (_us, results) = mapAccumL compile us branch_fcodes + (branch_results, branch_out_states) = unzip results + ; setState $ foldl stateIncUsage state branch_out_states + -- NB foldl. state is the *left* argument to stateIncUsage + ; return branch_results } \end{code} @forkEval@ takes two blocks of code. @@ -479,162 +636,204 @@ forkEval :: EndOfBlockInfo -- For the body -> FCode EndOfBlockInfo -- The new end of block info forkEval body_eob_info env_code body_code - = forkEvalHelp body_eob_info env_code body_code `thenFC` \ (v, sequel) -> - returnFC (EndOfBlockInfo v sequel) + = do { (v, sequel) <- forkEvalHelp body_eob_info env_code body_code + ; returnFC (EndOfBlockInfo v sequel) } forkEvalHelp :: EndOfBlockInfo -- For the body -> Code -- Code to set environment -> FCode a -- The code to do after the eval - -> FCode (Int, -- Sp - a) -- Result of the FCode - -forkEvalHelp body_eob_info env_code body_code = - do - info_down@(MkCgInfoDown cg_info statics srt ticky _) <- getInfoDown - state <- getState - let info_down_for_body = MkCgInfoDown cg_info statics srt ticky body_eob_info - let (_,MkCgState _ binds ((v,t,f,_,_),_)) = - doFCode env_code info_down_for_body state - let state_for_body = MkCgState AbsCNop - (nukeVolatileBinds binds) - ((v,t,f,v,v), (0,0)) - let (value_returned, state_at_end_return) = - doFCode body_code info_down_for_body state_for_body - setState $ state `stateIncUsageEval` state_at_end_return - return (v,value_returned) - -stateIncUsageEval :: CgState -> CgState -> CgState -stateIncUsageEval (MkCgState absC1 bs ((v,t,f,r,h1),heap_usage)) - (MkCgState absC2 _ ((_,_,_,_,h2), _)) - = MkCgState (absC1 `mkAbsCStmts` absC2) - -- The AbsC coming back should consist only of nested declarations, + -> FCode (VirtualSpOffset, -- Sp + a) -- Result of the FCode + -- A disturbingly complicated function +forkEvalHelp body_eob_info env_code body_code + = do { info_down@(MkCgInfoDown cg_info statics srt ticky _) <- getInfoDown + ; us <- newUniqSupply + ; state <- getState + ; let { info_down_for_body = info_down {cgd_eob = body_eob_info} + ; (_, env_state) = doFCode env_code info_down_for_body + (state {cgs_uniqs = us}) + ; state_for_body = (initCgState (cgs_uniqs env_state)) + { cgs_binds = binds_for_body, + cgs_stk_usg = stk_usg_for_body } + ; binds_for_body = nukeVolatileBinds (cgs_binds env_state) + ; stk_usg_from_env = cgs_stk_usg env_state + ; virtSp_from_env = virtSp stk_usg_from_env + ; stk_usg_for_body = stk_usg_from_env {realSp = virtSp_from_env, + hwSp = virtSp_from_env} + ; (value_returned, state_at_end_return) + = doFCode body_code info_down_for_body state_for_body + } + ; ASSERT( isNilOL (cgs_stmts state_at_end_return) ) + -- The code coming back should consist only of nested declarations, -- notably of the return vector! - bs - ((v,t,f,r,h1 `max` h2), heap_usage) - -- We don't max the heap high-watermark because stateIncUsageEval is - -- used only in forkEval, which in turn is only used for blocks of code - -- which do their own heap-check. -\end{code} + setState $ state `stateIncUsageEval` state_at_end_return + ; return (virtSp_from_env, value_returned) } -%************************************************************************ -%* * -\subsection[CgMonad-spitting-AbstractC]{Spitting out @AbstractC@} -%* * -%************************************************************************ -@nopC@ is the no-op for the @Code@ monad; it adds no Abstract~C to the -environment; @absC@ glues @ab_C@ onto the Abstract~C collected so far. -\begin{code} +-- ---------------------------------------------------------------------------- +-- Combinators for emitting code + nopC :: Code nopC = return () -absC :: AbstractC -> Code -absC more_absC = do - state@(MkCgState absC binds usage) <- getState - setState $ MkCgState (mkAbsCStmts absC more_absC) binds usage -\end{code} - -These two are just like @absC@, except they examine the compilation -info (whether SCC profiling or profiling-ctrs going) and possibly emit -nothing. - -\begin{code} -costCentresC :: FastString -> [CAddrMode] -> Code -costCentresC macro args - | opt_SccProfilingOn = absC (CCallProfCCMacro macro args) - | otherwise = nopC - -profCtrC :: FastString -> [CAddrMode] -> Code -profCtrC macro args - | opt_DoTickyProfiling = absC (CCallProfCtrMacro macro args) - | otherwise = nopC - -profCtrAbsC :: FastString -> [CAddrMode] -> AbstractC -profCtrAbsC macro args - | opt_DoTickyProfiling = CCallProfCtrMacro macro args - | otherwise = AbsCNop - -ldvEnter :: Code -ldvEnter = costCentresC FSLIT("LDV_ENTER") [CReg node] - -{- Try to avoid adding too many special compilation strategies here. - It's better to modify the header files as necessary for particular - targets, so that we can get away with as few variants of .hc files - as possible. --} -\end{code} - -@getAbsC@ compiles the code in the current environment, and returns -the abstract C thus constructed (leaving the abstract C being carried -around in the state untouched). @getAbsC@ does not generate any -in-line Abstract~C itself, but the environment it returns is that -obtained from the compilation. +whenC :: Bool -> Code -> Code +whenC True code = code +whenC False code = nopC + +stmtC :: CmmStmt -> Code +stmtC stmt = emitCgStmt (CgStmt stmt) + +labelC :: BlockId -> Code +labelC id = emitCgStmt (CgLabel id) + +newLabelC :: FCode BlockId +newLabelC = do { id <- newUnique; return (BlockId id) } + +checkedAbsC :: CmmStmt -> Code +-- Emit code, eliminating no-ops +checkedAbsC stmt = emitStmts (if isNopStmt stmt then nilOL + else unitOL stmt) + +stmtsC :: [CmmStmt] -> Code +stmtsC stmts = emitStmts (toOL stmts) + +-- Emit code; no no-op checking +emitStmts :: CmmStmts -> Code +emitStmts stmts = emitCgStmts (fmap CgStmt stmts) + +-- forkLabelledCode is for emitting a chunk of code with a label, outside +-- of the current instruction stream. +forkLabelledCode :: Code -> FCode BlockId +forkLabelledCode code = getCgStmts code >>= forkCgStmts + +emitCgStmt :: CgStmt -> Code +emitCgStmt stmt + = do { state <- getState + ; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt } + } + +emitData :: Section -> [CmmStatic] -> Code +emitData sect lits + = do { state <- getState + ; setState $ state { cgs_tops = cgs_tops state `snocOL` data_block } } + where + data_block = CmmData sect lits + +emitProc :: [CmmLit] -> CLabel -> [LocalReg] -> [CmmBasicBlock] -> Code +emitProc lits lbl args blocks + = do { let proc_block = CmmProc (map CmmStaticLit lits) lbl args blocks + ; state <- getState + ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } } + +emitSimpleProc :: CLabel -> Code -> Code +-- Emit a procedure whose body is the specified code; no info table +emitSimpleProc lbl code + = do { stmts <- getCgStmts code + ; blks <- cgStmtsToBlocks stmts + ; emitProc [] lbl [] blks } + +getCmm :: Code -> FCode Cmm +-- Get all the CmmTops (there should be no stmts) +getCmm code + = do { state1 <- getState + ; ((), state2) <- withState code (state1 { cgs_tops = nilOL }) + ; setState $ state2 { cgs_tops = cgs_tops state1 } + ; return (Cmm (fromOL (cgs_tops state2))) } + +-- ---------------------------------------------------------------------------- +-- CgStmts + +-- These functions deal in terms of CgStmts, which is an abstract type +-- representing the code in the current proc. + + +-- emit CgStmts into the current instruction stream +emitCgStmts :: CgStmts -> Code +emitCgStmts stmts + = do { state <- getState + ; setState $ state { cgs_stmts = cgs_stmts state `appOL` stmts } } + +-- emit CgStmts outside the current instruction stream, and return a label +forkCgStmts :: CgStmts -> FCode BlockId +forkCgStmts stmts + = do { id <- newLabelC + ; emitCgStmt (CgFork id stmts) + ; return id + } + +-- turn CgStmts into [CmmBasicBlock], for making a new proc. +cgStmtsToBlocks :: CgStmts -> FCode [CmmBasicBlock] +cgStmtsToBlocks stmts + = do { id <- newLabelC + ; return (flattenCgStmts id stmts) + } + +-- collect the code emitted by an FCode computation +getCgStmts' :: FCode a -> FCode (a, CgStmts) +getCgStmts' fcode + = do { state1 <- getState + ; (a, state2) <- withState fcode (state1 { cgs_stmts = nilOL }) + ; setState $ state2 { cgs_stmts = cgs_stmts state1 } + ; return (a, cgs_stmts state2) } + +getCgStmts :: FCode a -> FCode CgStmts +getCgStmts fcode = do { (_,stmts) <- getCgStmts' fcode; return stmts } + +-- Simple ways to construct CgStmts: +noCgStmts :: CgStmts +noCgStmts = nilOL + +oneCgStmt :: CmmStmt -> CgStmts +oneCgStmt stmt = unitOL (CgStmt stmt) + +consCgStmt :: CmmStmt -> CgStmts -> CgStmts +consCgStmt stmt stmts = CgStmt stmt `consOL` stmts + +-- ---------------------------------------------------------------------------- +-- Get the current module name -\begin{code} -getAbsC :: Code -> FCode AbstractC -getAbsC code = do - MkCgState absC binds usage <- getState - ((),MkCgState absC2 binds2 usage2) <- withState code (MkCgState AbsCNop binds usage) - setState $ MkCgState absC binds2 usage2 - return absC2 -\end{code} - -\begin{code} moduleName :: FCode Module -moduleName = do - (MkCgInfoDown (MkCompInfo mod_name) _ _ _ _) <- getInfoDown - return mod_name -\end{code} +moduleName = do { info <- getInfoDown; return (cgd_mod info) } + +-- ---------------------------------------------------------------------------- +-- Get/set the end-of-block info -\begin{code} setEndOfBlockInfo :: EndOfBlockInfo -> Code -> Code setEndOfBlockInfo eob_info code = do - (MkCgInfoDown c_info statics srt ticky _) <- getInfoDown - withInfoDown code (MkCgInfoDown c_info statics srt ticky eob_info) + info <- getInfoDown + withInfoDown code (info {cgd_eob = eob_info}) getEndOfBlockInfo :: FCode EndOfBlockInfo getEndOfBlockInfo = do - (MkCgInfoDown c_info statics _ _ eob_info) <- getInfoDown - return eob_info -\end{code} + info <- getInfoDown + return (cgd_eob info) -There is just one SRT for each top level binding; all the nested -bindings use sub-sections of this SRT. The label is passed down to -the nested bindings via the monad. +-- ---------------------------------------------------------------------------- +-- Get/set the current SRT label -\begin{code} -getSRTInfo :: Name -> SRT -> FCode C_SRT -getSRTInfo id NoSRT = return NoC_SRT -getSRTInfo id (SRT off len bmp) - | len > hALF_WORD || bmp == [fromIntegral srt_escape] = do - srt_lbl <- getSRTLabel - let srt_desc_lbl = mkSRTDescLabel id - absC (CSRTDesc srt_desc_lbl srt_lbl off len bmp) - return (C_SRT srt_desc_lbl 0 srt_escape) - | otherwise = do - srt_lbl <- getSRTLabel - return (C_SRT srt_lbl off (fromIntegral (head bmp))) - -srt_escape = (-1) :: StgHalfWord +-- There is just one SRT for each top level binding; all the nested +-- bindings use sub-sections of this SRT. The label is passed down to +-- the nested bindings via the monad. getSRTLabel :: FCode CLabel -- Used only by cgPanic -getSRTLabel = do MkCgInfoDown _ _ srt_lbl _ _ <- getInfoDown - return srt_lbl +getSRTLabel = do info <- getInfoDown + return (cgd_srt info) setSRTLabel :: CLabel -> FCode a -> FCode a setSRTLabel srt_lbl code - = do MkCgInfoDown c_info statics _ ticky eob_info <- getInfoDown - withInfoDown code (MkCgInfoDown c_info statics srt_lbl ticky eob_info) -\end{code} + = do info <- getInfoDown + withInfoDown code (info { cgd_srt = srt_lbl}) + +-- ---------------------------------------------------------------------------- +-- Get/set the current ticky counter label -\begin{code} getTickyCtrLabel :: FCode CLabel getTickyCtrLabel = do - (MkCgInfoDown _ _ _ ticky _) <- getInfoDown - return ticky + info <- getInfoDown + return (cgd_ticky info) setTickyCtrLabel :: CLabel -> Code -> Code setTickyCtrLabel ticky code = do - (MkCgInfoDown c_info statics srt _ eob_info) <- getInfoDown - withInfoDown code (MkCgInfoDown c_info statics srt ticky eob_info) + info <- getInfoDown + withInfoDown code (info {cgd_ticky = ticky}) \end{code} diff --git a/ghc/compiler/codeGen/CgParallel.hs b/ghc/compiler/codeGen/CgParallel.hs new file mode 100644 index 0000000000..74cbeb5fda --- /dev/null +++ b/ghc/compiler/codeGen/CgParallel.hs @@ -0,0 +1,90 @@ +-- Code generation relaed to GpH +-- (a) parallel +-- (b) GranSim + +module CgParallel( + staticGranHdr,staticParHdr, + granFetchAndReschedule, granYield, + doGranAllocate + ) where + +import CgMonad +import CgCallConv ( mkRegLiveness ) +import Id ( Id ) +import Cmm ( CmmLit, GlobalReg(..), node, CmmExpr ) +import CmdLineOpts ( opt_GranMacros ) +import Outputable + +staticParHdr :: [CmmLit] +-- Parallel header words in a static closure +staticParHdr = [] + +-------------------------------------------------------- +-- GranSim stuff +-------------------------------------------------------- + +staticGranHdr :: [CmmLit] +-- Gransim header words in a static closure +staticGranHdr = [] + +doGranAllocate :: CmmExpr -> Code +-- macro DO_GRAN_ALLOCATE +doGranAllocate hp + | not opt_GranMacros = nopC + | otherwise = panic "doGranAllocate" + + + +------------------------- +granFetchAndReschedule :: [(Id,GlobalReg)] -- Live registers + -> Bool -- Node reqd? + -> Code +-- Emit code for simulating a fetch and then reschedule. +granFetchAndReschedule regs node_reqd + | opt_GranMacros && (node `elem` map snd regs || node_reqd) + = do { fetch + ; reschedule liveness node_reqd } + | otherwise + = nopC + where + liveness = mkRegLiveness regs 0 0 + +fetch = panic "granFetch" + -- Was: absC (CMacroStmt GRAN_FETCH []) + --HWL: generate GRAN_FETCH macro for GrAnSim + -- currently GRAN_FETCH and GRAN_FETCH_AND_RESCHEDULE are miai + +reschedule liveness node_reqd = panic "granReschedule" + -- Was: absC (CMacroStmt GRAN_RESCHEDULE [ + -- mkIntCLit (I# (word2Int# liveness_mask)), + -- mkIntCLit (if node_reqd then 1 else 0)]) + + +------------------------- +-- The @GRAN_YIELD@ macro is taken from JSM's code for Concurrent Haskell. It +-- allows to context-switch at places where @node@ is not alive (it uses the +-- @Continue@ rather than the @EnterNodeCode@ function in the RTS). We emit +-- this kind of macro at the beginning of the following kinds of basic bocks: +-- \begin{itemize} +-- \item Slow entry code where node is not alive (see @CgClosure.lhs@). Normally +-- we use @fetchAndReschedule@ at a slow entry code. +-- \item Fast entry code (see @CgClosure.lhs@). +-- \item Alternatives in case expressions (@CLabelledCode@ structures), provided +-- that they are not inlined (see @CgCases.lhs@). These alternatives will +-- be turned into separate functions. + +granYield :: [(Id,GlobalReg)] -- Live registers + -> Bool -- Node reqd? + -> Code + +granYield regs node_reqd + | opt_GranMacros && node_reqd = yield liveness + | otherwise = nopC + where + liveness = mkRegLiveness regs 0 0 + +yield liveness = panic "granYield" + -- Was : absC (CMacroStmt GRAN_YIELD + -- [mkIntCLit (I# (word2Int# liveness_mask))]) + + diff --git a/ghc/compiler/codeGen/CgPrimOp.hs b/ghc/compiler/codeGen/CgPrimOp.hs new file mode 100644 index 0000000000..65ad0cc724 --- /dev/null +++ b/ghc/compiler/codeGen/CgPrimOp.hs @@ -0,0 +1,588 @@ +----------------------------------------------------------------------------- +-- +-- Code generation for PrimOps. +-- +-- (c) The University of Glasgow 2004 +-- +----------------------------------------------------------------------------- + +module CgPrimOp ( + cgPrimOp + ) where + +import StgSyn ( StgLiveVars, StgArg ) +import CgBindery ( getVolatileRegs, getArgAmodes ) +import CgMonad +import CgInfoTbls ( getConstrTag ) +import CgUtils ( cmmOffsetW, cmmOffsetB, cmmLoadIndexW ) +import Cmm +import CLabel ( mkMAP_FROZEN_infoLabel ) +import CmmUtils +import MachOp +import SMRep +import PrimOp ( PrimOp(..) ) +import SMRep ( tablesNextToCode ) +import Constants ( wORD_SIZE, wORD_SIZE_IN_BITS ) +import Outputable + +-- --------------------------------------------------------------------------- +-- Code generation for PrimOps + +cgPrimOp :: [CmmReg] -- where to put the results + -> PrimOp -- the op + -> [StgArg] -- arguments + -> StgLiveVars -- live vars, in case we need to save them + -> Code + +cgPrimOp results op args live + = do arg_exprs <- getArgAmodes args + let non_void_args = [ e | (r,e) <- arg_exprs, nonVoidArg r ] + emitPrimOp results op non_void_args live + + +emitPrimOp :: [CmmReg] -- where to put the results + -> PrimOp -- the op + -> [CmmExpr] -- arguments + -> StgLiveVars -- live vars, in case we need to save them + -> Code + +-- First we handle various awkward cases specially. The remaining +-- easy cases are then handled by translateOp, defined below. + +emitPrimOp [res_r,res_c] IntAddCOp [aa,bb] live +{- + With some bit-twiddling, we can define int{Add,Sub}Czh portably in + C, and without needing any comparisons. This may not be the + fastest way to do it - if you have better code, please send it! --SDM + + Return : r = a + b, c = 0 if no overflow, 1 on overflow. + + We currently don't make use of the r value if c is != 0 (i.e. + overflow), we just convert to big integers and try again. This + could be improved by making r and c the correct values for + plugging into a new J#. + + { r = ((I_)(a)) + ((I_)(b)); \ + c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \ + >> (BITS_IN (I_) - 1); \ + } + Wading through the mass of bracketry, it seems to reduce to: + c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1) + +-} + = stmtsC [ + CmmAssign res_r (CmmMachOp mo_wordAdd [aa,bb]), + CmmAssign res_c $ + CmmMachOp mo_wordUShr [ + CmmMachOp mo_wordAnd [ + CmmMachOp mo_wordNot [CmmMachOp mo_wordXor [aa,bb]], + CmmMachOp mo_wordXor [aa, CmmReg res_r] + ], + CmmLit (mkIntCLit (wORD_SIZE_IN_BITS - 1)) + ] + ] + + +emitPrimOp [res_r,res_c] IntSubCOp [aa,bb] live +{- Similarly: + #define subIntCzh(r,c,a,b) \ + { r = ((I_)(a)) - ((I_)(b)); \ + c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \ + >> (BITS_IN (I_) - 1); \ + } + + c = ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1) +-} + = stmtsC [ + CmmAssign res_r (CmmMachOp mo_wordSub [aa,bb]), + CmmAssign res_c $ + CmmMachOp mo_wordUShr [ + CmmMachOp mo_wordAnd [ + CmmMachOp mo_wordXor [aa,bb], + CmmMachOp mo_wordXor [aa, CmmReg res_r] + ], + CmmLit (mkIntCLit (wORD_SIZE_IN_BITS - 1)) + ] + ] + + +emitPrimOp [res] ParOp [arg] live + = stmtC (CmmAssign res (CmmLit (mkIntCLit 1))) + +emitPrimOp [res] ReadMutVarOp [mutv] live + = stmtC (CmmAssign res (cmmLoadIndexW mutv fixedHdrSize)) + +emitPrimOp [] WriteMutVarOp [mutv,var] live + = stmtC (CmmStore (cmmOffsetW mutv fixedHdrSize) var) + +emitPrimOp [res] ForeignObjToAddrOp [fo] live + = stmtC (CmmAssign res (cmmLoadIndexW fo fixedHdrSize)) + +emitPrimOp [] WriteForeignObjOp [fo,addr] live + = stmtC (CmmStore (cmmOffsetW fo fixedHdrSize) addr) + +-- #define sizzeofByteArrayzh(r,a) \ +-- r = (((StgArrWords *)(a))->words * sizeof(W_)) +emitPrimOp [res] SizeofByteArrayOp [arg] live + = stmtC $ + CmmAssign res (CmmMachOp mo_wordMul [ + cmmLoadIndexW arg fixedHdrSize, + CmmLit (mkIntCLit wORD_SIZE) + ]) + +-- #define sizzeofMutableByteArrayzh(r,a) \ +-- r = (((StgArrWords *)(a))->words * sizeof(W_)) +emitPrimOp [res] SizeofMutableByteArrayOp [arg] live + = emitPrimOp [res] SizeofByteArrayOp [arg] live + + +-- #define touchzh(o) /* nothing */ +emitPrimOp [] TouchOp [arg] live + = nopC + +-- #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a) +emitPrimOp [res] ByteArrayContents_Char [arg] live + = stmtC (CmmAssign res (cmmOffsetB arg arrWordsHdrSize)) + +-- #define stableNameToIntzh(r,s) (r = ((StgStableName *)s)->sn) +emitPrimOp [res] StableNameToIntOp [arg] live + = stmtC (CmmAssign res (cmmLoadIndexW arg fixedHdrSize)) + +-- #define eqStableNamezh(r,sn1,sn2) \ +-- (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn)) +emitPrimOp [res] EqStableNameOp [arg1,arg2] live + = stmtC (CmmAssign res (CmmMachOp mo_wordEq [ + cmmLoadIndexW arg1 fixedHdrSize, + cmmLoadIndexW arg2 fixedHdrSize + ])) + + +emitPrimOp [res] ReallyUnsafePtrEqualityOp [arg1,arg2] live + = stmtC (CmmAssign res (CmmMachOp mo_wordEq [arg1,arg2])) + +-- #define addrToHValuezh(r,a) r=(P_)a +emitPrimOp [res] AddrToHValueOp [arg] live + = stmtC (CmmAssign res arg) + +-- #define dataToTagzh(r,a) r=(GET_TAG(((StgClosure *)a)->header.info)) +emitPrimOp [res] DataToTagOp [arg] live + = stmtC (CmmAssign res (getConstrTag arg)) + +{- Freezing arrays-of-ptrs requires changing an info table, for the + benefit of the generational collector. It needs to scavenge mutable + objects, even if they are in old space. When they become immutable, + they can be removed from this scavenge list. -} + +-- #define unsafeFreezzeArrayzh(r,a) +-- { +-- SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN_info); +-- r = a; +-- } +emitPrimOp [res] UnsafeFreezeArrayOp [arg] live + = stmtsC [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_infoLabel)), + CmmAssign res arg ] + +-- #define unsafeFreezzeByteArrayzh(r,a) r=(a) +emitPrimOp [res] UnsafeFreezeByteArrayOp [arg] live + = stmtC (CmmAssign res arg) + +-- Reading/writing pointer arrays + +emitPrimOp [r] ReadArrayOp [obj,ix] live = doReadPtrArrayOp r obj ix +emitPrimOp [r] IndexArrayOp [obj,ix] live = doReadPtrArrayOp r obj ix +emitPrimOp [] WriteArrayOp [obj,ix,v] live = doWritePtrArrayOp obj ix v + +-- IndexXXXoffForeignObj + +emitPrimOp res IndexOffForeignObjOp_Char args live = doIndexOffForeignObjOp (Just mo_u_8ToWord) I8 res args +emitPrimOp res IndexOffForeignObjOp_WideChar args live = doIndexOffForeignObjOp (Just mo_u_32ToWord) I32 res args +emitPrimOp res IndexOffForeignObjOp_Int args live = doIndexOffForeignObjOp Nothing wordRep res args +emitPrimOp res IndexOffForeignObjOp_Word args live = doIndexOffForeignObjOp Nothing wordRep res args +emitPrimOp res IndexOffForeignObjOp_Addr args live = doIndexOffForeignObjOp Nothing wordRep res args +emitPrimOp res IndexOffForeignObjOp_Float args live = doIndexOffForeignObjOp Nothing F32 res args +emitPrimOp res IndexOffForeignObjOp_Double args live = doIndexOffForeignObjOp Nothing F64 res args +emitPrimOp res IndexOffForeignObjOp_StablePtr args live = doIndexOffForeignObjOp Nothing wordRep res args +emitPrimOp res IndexOffForeignObjOp_Int8 args live = doIndexOffForeignObjOp (Just mo_s_8ToWord) I8 res args +emitPrimOp res IndexOffForeignObjOp_Int16 args live = doIndexOffForeignObjOp (Just mo_s_16ToWord) I16 res args +emitPrimOp res IndexOffForeignObjOp_Int32 args live = doIndexOffForeignObjOp (Just mo_s_32ToWord) I32 res args +emitPrimOp res IndexOffForeignObjOp_Int64 args live = doIndexOffForeignObjOp Nothing I64 res args +emitPrimOp res IndexOffForeignObjOp_Word8 args live = doIndexOffForeignObjOp (Just mo_u_8ToWord) I8 res args +emitPrimOp res IndexOffForeignObjOp_Word16 args live = doIndexOffForeignObjOp (Just mo_u_16ToWord) I16 res args +emitPrimOp res IndexOffForeignObjOp_Word32 args live = doIndexOffForeignObjOp (Just mo_u_32ToWord) I32 res args +emitPrimOp res IndexOffForeignObjOp_Word64 args live = doIndexOffForeignObjOp Nothing I64 res args + +-- IndexXXXoffAddr + +emitPrimOp res IndexOffAddrOp_Char args live = doIndexOffAddrOp (Just mo_u_8ToWord) I8 res args +emitPrimOp res IndexOffAddrOp_WideChar args live = doIndexOffAddrOp (Just mo_u_32ToWord) I32 res args +emitPrimOp res IndexOffAddrOp_Int args live = doIndexOffAddrOp Nothing wordRep res args +emitPrimOp res IndexOffAddrOp_Word args live = doIndexOffAddrOp Nothing wordRep res args +emitPrimOp res IndexOffAddrOp_Addr args live = doIndexOffAddrOp Nothing wordRep res args +emitPrimOp res IndexOffAddrOp_Float args live = doIndexOffAddrOp Nothing F32 res args +emitPrimOp res IndexOffAddrOp_Double args live = doIndexOffAddrOp Nothing F64 res args +emitPrimOp res IndexOffAddrOp_StablePtr args live = doIndexOffAddrOp Nothing wordRep res args +emitPrimOp res IndexOffAddrOp_Int8 args live = doIndexOffAddrOp (Just mo_s_8ToWord) I8 res args +emitPrimOp res IndexOffAddrOp_Int16 args live = doIndexOffAddrOp (Just mo_s_16ToWord) I16 res args +emitPrimOp res IndexOffAddrOp_Int32 args live = doIndexOffAddrOp (Just mo_s_32ToWord) I32 res args +emitPrimOp res IndexOffAddrOp_Int64 args live = doIndexOffAddrOp Nothing I64 res args +emitPrimOp res IndexOffAddrOp_Word8 args live = doIndexOffAddrOp (Just mo_u_8ToWord) I8 res args +emitPrimOp res IndexOffAddrOp_Word16 args live = doIndexOffAddrOp (Just mo_u_16ToWord) I16 res args +emitPrimOp res IndexOffAddrOp_Word32 args live = doIndexOffAddrOp (Just mo_u_32ToWord) I32 res args +emitPrimOp res IndexOffAddrOp_Word64 args live = doIndexOffAddrOp Nothing I64 res args + +-- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr. + +emitPrimOp res ReadOffAddrOp_Char args live = doIndexOffAddrOp (Just mo_u_8ToWord) I8 res args +emitPrimOp res ReadOffAddrOp_WideChar args live = doIndexOffAddrOp (Just mo_u_32ToWord) I32 res args +emitPrimOp res ReadOffAddrOp_Int args live = doIndexOffAddrOp Nothing wordRep res args +emitPrimOp res ReadOffAddrOp_Word args live = doIndexOffAddrOp Nothing wordRep res args +emitPrimOp res ReadOffAddrOp_Addr args live = doIndexOffAddrOp Nothing wordRep res args +emitPrimOp res ReadOffAddrOp_Float args live = doIndexOffAddrOp Nothing F32 res args +emitPrimOp res ReadOffAddrOp_Double args live = doIndexOffAddrOp Nothing F64 res args +emitPrimOp res ReadOffAddrOp_StablePtr args live = doIndexOffAddrOp Nothing wordRep res args +emitPrimOp res ReadOffAddrOp_Int8 args live = doIndexOffAddrOp (Just mo_s_8ToWord) I8 res args +emitPrimOp res ReadOffAddrOp_Int16 args live = doIndexOffAddrOp (Just mo_s_16ToWord) I16 res args +emitPrimOp res ReadOffAddrOp_Int32 args live = doIndexOffAddrOp (Just mo_s_32ToWord) I32 res args +emitPrimOp res ReadOffAddrOp_Int64 args live = doIndexOffAddrOp Nothing I64 res args +emitPrimOp res ReadOffAddrOp_Word8 args live = doIndexOffAddrOp (Just mo_u_8ToWord) I8 res args +emitPrimOp res ReadOffAddrOp_Word16 args live = doIndexOffAddrOp (Just mo_u_16ToWord) I16 res args +emitPrimOp res ReadOffAddrOp_Word32 args live = doIndexOffAddrOp (Just mo_u_32ToWord) I32 res args +emitPrimOp res ReadOffAddrOp_Word64 args live = doIndexOffAddrOp Nothing I64 res args + +-- IndexXXXArray + +emitPrimOp res IndexByteArrayOp_Char args live = doIndexByteArrayOp (Just mo_u_8ToWord) I8 res args +emitPrimOp res IndexByteArrayOp_WideChar args live = doIndexByteArrayOp (Just mo_u_32ToWord) I32 res args +emitPrimOp res IndexByteArrayOp_Int args live = doIndexByteArrayOp Nothing wordRep res args +emitPrimOp res IndexByteArrayOp_Word args live = doIndexByteArrayOp Nothing wordRep res args +emitPrimOp res IndexByteArrayOp_Addr args live = doIndexByteArrayOp Nothing wordRep res args +emitPrimOp res IndexByteArrayOp_Float args live = doIndexByteArrayOp Nothing F32 res args +emitPrimOp res IndexByteArrayOp_Double args live = doIndexByteArrayOp Nothing F64 res args +emitPrimOp res IndexByteArrayOp_StablePtr args live = doIndexByteArrayOp Nothing wordRep res args +emitPrimOp res IndexByteArrayOp_Int8 args live = doIndexByteArrayOp (Just mo_s_8ToWord) I8 res args +emitPrimOp res IndexByteArrayOp_Int16 args live = doIndexByteArrayOp (Just mo_s_16ToWord) I16 res args +emitPrimOp res IndexByteArrayOp_Int32 args live = doIndexByteArrayOp (Just mo_s_32ToWord) I32 res args +emitPrimOp res IndexByteArrayOp_Int64 args live = doIndexByteArrayOp Nothing I64 res args +emitPrimOp res IndexByteArrayOp_Word8 args live = doIndexByteArrayOp (Just mo_u_8ToWord) I8 res args +emitPrimOp res IndexByteArrayOp_Word16 args live = doIndexByteArrayOp (Just mo_u_16ToWord) I16 res args +emitPrimOp res IndexByteArrayOp_Word32 args live = doIndexByteArrayOp (Just mo_u_32ToWord) I32 res args +emitPrimOp res IndexByteArrayOp_Word64 args live = doIndexByteArrayOp Nothing I64 res args + +-- ReadXXXArray, identical to IndexXXXArray. + +emitPrimOp res ReadByteArrayOp_Char args live = doIndexByteArrayOp (Just mo_u_8ToWord) I8 res args +emitPrimOp res ReadByteArrayOp_WideChar args live = doIndexByteArrayOp (Just mo_u_32ToWord) I32 res args +emitPrimOp res ReadByteArrayOp_Int args live = doIndexByteArrayOp Nothing wordRep res args +emitPrimOp res ReadByteArrayOp_Word args live = doIndexByteArrayOp Nothing wordRep res args +emitPrimOp res ReadByteArrayOp_Addr args live = doIndexByteArrayOp Nothing wordRep res args +emitPrimOp res ReadByteArrayOp_Float args live = doIndexByteArrayOp Nothing F32 res args +emitPrimOp res ReadByteArrayOp_Double args live = doIndexByteArrayOp Nothing F64 res args +emitPrimOp res ReadByteArrayOp_StablePtr args live = doIndexByteArrayOp Nothing wordRep res args +emitPrimOp res ReadByteArrayOp_Int8 args live = doIndexByteArrayOp (Just mo_s_8ToWord) I8 res args +emitPrimOp res ReadByteArrayOp_Int16 args live = doIndexByteArrayOp (Just mo_s_16ToWord) I16 res args +emitPrimOp res ReadByteArrayOp_Int32 args live = doIndexByteArrayOp (Just mo_s_32ToWord) I32 res args +emitPrimOp res ReadByteArrayOp_Int64 args live = doIndexByteArrayOp Nothing I64 res args +emitPrimOp res ReadByteArrayOp_Word8 args live = doIndexByteArrayOp (Just mo_u_8ToWord) I8 res args +emitPrimOp res ReadByteArrayOp_Word16 args live = doIndexByteArrayOp (Just mo_u_16ToWord) I16 res args +emitPrimOp res ReadByteArrayOp_Word32 args live = doIndexByteArrayOp (Just mo_u_32ToWord) I32 res args +emitPrimOp res ReadByteArrayOp_Word64 args live = doIndexByteArrayOp Nothing I64 res args + +-- WriteXXXoffAddr + +emitPrimOp res WriteOffAddrOp_Char args live = doWriteOffAddrOp (Just mo_WordTo8) I8 res args +emitPrimOp res WriteOffAddrOp_WideChar args live = doWriteOffAddrOp (Just mo_WordTo32) I32 res args +emitPrimOp res WriteOffAddrOp_Int args live = doWriteOffAddrOp Nothing wordRep res args +emitPrimOp res WriteOffAddrOp_Word args live = doWriteOffAddrOp Nothing wordRep res args +emitPrimOp res WriteOffAddrOp_Addr args live = doWriteOffAddrOp Nothing wordRep res args +emitPrimOp res WriteOffAddrOp_Float args live = doWriteOffAddrOp Nothing F32 res args +emitPrimOp res WriteOffAddrOp_ForeignObj args live = doWriteOffAddrOp Nothing wordRep res args +emitPrimOp res WriteOffAddrOp_Double args live = doWriteOffAddrOp Nothing F64 res args +emitPrimOp res WriteOffAddrOp_StablePtr args live = doWriteOffAddrOp Nothing wordRep res args +emitPrimOp res WriteOffAddrOp_Int8 args live = doWriteOffAddrOp (Just mo_WordTo8) I8 res args +emitPrimOp res WriteOffAddrOp_Int16 args live = doWriteOffAddrOp (Just mo_WordTo16) I16 res args +emitPrimOp res WriteOffAddrOp_Int32 args live = doWriteOffAddrOp (Just mo_WordTo32) I32 res args +emitPrimOp res WriteOffAddrOp_Int64 args live = doWriteOffAddrOp Nothing I64 res args +emitPrimOp res WriteOffAddrOp_Word8 args live = doWriteOffAddrOp (Just mo_WordTo8) I8 res args +emitPrimOp res WriteOffAddrOp_Word16 args live = doWriteOffAddrOp (Just mo_WordTo16) I16 res args +emitPrimOp res WriteOffAddrOp_Word32 args live = doWriteOffAddrOp (Just mo_WordTo32) I32 res args +emitPrimOp res WriteOffAddrOp_Word64 args live = doWriteOffAddrOp Nothing I64 res args + +-- WriteXXXArray + +emitPrimOp res WriteByteArrayOp_Char args live = doWriteByteArrayOp (Just mo_WordTo8) I8 res args +emitPrimOp res WriteByteArrayOp_WideChar args live = doWriteByteArrayOp (Just mo_WordTo32) I32 res args +emitPrimOp res WriteByteArrayOp_Int args live = doWriteByteArrayOp Nothing wordRep res args +emitPrimOp res WriteByteArrayOp_Word args live = doWriteByteArrayOp Nothing wordRep res args +emitPrimOp res WriteByteArrayOp_Addr args live = doWriteByteArrayOp Nothing wordRep res args +emitPrimOp res WriteByteArrayOp_Float args live = doWriteByteArrayOp Nothing F32 res args +emitPrimOp res WriteByteArrayOp_Double args live = doWriteByteArrayOp Nothing F64 res args +emitPrimOp res WriteByteArrayOp_StablePtr args live = doWriteByteArrayOp Nothing wordRep res args +emitPrimOp res WriteByteArrayOp_Int8 args live = doWriteByteArrayOp (Just mo_WordTo8) I8 res args +emitPrimOp res WriteByteArrayOp_Int16 args live = doWriteByteArrayOp (Just mo_WordTo16) I16 res args +emitPrimOp res WriteByteArrayOp_Int32 args live = doWriteByteArrayOp (Just mo_WordTo32) I32 res args +emitPrimOp res WriteByteArrayOp_Int64 args live = doWriteByteArrayOp Nothing I64 res args +emitPrimOp res WriteByteArrayOp_Word8 args live = doWriteByteArrayOp (Just mo_WordTo8) I8 res args +emitPrimOp res WriteByteArrayOp_Word16 args live = doWriteByteArrayOp (Just mo_WordTo16) I16 res args +emitPrimOp res WriteByteArrayOp_Word32 args live = doWriteByteArrayOp (Just mo_WordTo32) I32 res args +emitPrimOp res WriteByteArrayOp_Word64 args live = doWriteByteArrayOp Nothing I64 res args + + +-- The rest just translate straightforwardly +emitPrimOp [res] op [arg] live + | nopOp op + = stmtC (CmmAssign res arg) + + | Just (mop,rep) <- narrowOp op + = stmtC (CmmAssign res (CmmMachOp (mop rep wordRep) [ + CmmMachOp (mop wordRep rep) [arg]])) + +emitPrimOp [res] op args live + | Just prim <- callishOp op + = do vols <- getVolatileRegs live + stmtC (CmmCall (CmmPrim prim) [(res,NoHint)] + [(a,NoHint) | a<-args] (Just vols)) -- ToDo: hints? + + | Just mop <- translateOp op + = let stmt = CmmAssign res (CmmMachOp mop args) in + stmtC stmt + +emitPrimOp _ op _ _ + = pprPanic "emitPrimOp: can't translate PrimOp" (ppr op) + + +-- These PrimOps are NOPs in Cmm + +nopOp Int2WordOp = True +nopOp Word2IntOp = True +nopOp Int2AddrOp = True +nopOp Addr2IntOp = True +nopOp _ = False + +-- These PrimOps turn into double casts + +narrowOp Narrow8IntOp = Just (MO_S_Conv, I8) +narrowOp Narrow16IntOp = Just (MO_S_Conv, I16) +narrowOp Narrow32IntOp = Just (MO_S_Conv, I32) +narrowOp Narrow8WordOp = Just (MO_U_Conv, I8) +narrowOp Narrow16WordOp = Just (MO_U_Conv, I16) +narrowOp Narrow32WordOp = Just (MO_U_Conv, I32) +narrowOp _ = Nothing + +-- Native word signless ops + +translateOp IntAddOp = Just mo_wordAdd +translateOp IntSubOp = Just mo_wordSub +translateOp WordAddOp = Just mo_wordAdd +translateOp WordSubOp = Just mo_wordSub +translateOp AddrAddOp = Just mo_wordAdd +translateOp AddrSubOp = Just mo_wordSub + +translateOp IntEqOp = Just mo_wordEq +translateOp IntNeOp = Just mo_wordNe +translateOp WordEqOp = Just mo_wordEq +translateOp WordNeOp = Just mo_wordNe +translateOp AddrEqOp = Just mo_wordEq +translateOp AddrNeOp = Just mo_wordNe + +translateOp AndOp = Just mo_wordAnd +translateOp OrOp = Just mo_wordOr +translateOp XorOp = Just mo_wordXor +translateOp NotOp = Just mo_wordNot +translateOp SllOp = Just mo_wordShl +translateOp SrlOp = Just mo_wordUShr + +translateOp AddrRemOp = Just mo_wordURem + +-- Native word signed ops + +translateOp IntMulOp = Just mo_wordMul +translateOp IntMulMayOfloOp = Just (MO_S_MulMayOflo wordRep) +translateOp IntQuotOp = Just mo_wordSQuot +translateOp IntRemOp = Just mo_wordSRem +translateOp IntNegOp = Just mo_wordSNeg + + +translateOp IntGeOp = Just mo_wordSGe +translateOp IntLeOp = Just mo_wordSLe +translateOp IntGtOp = Just mo_wordSGt +translateOp IntLtOp = Just mo_wordSLt + +translateOp ISllOp = Just mo_wordShl +translateOp ISraOp = Just mo_wordSShr +translateOp ISrlOp = Just mo_wordUShr + +-- Native word unsigned ops + +translateOp WordGeOp = Just mo_wordUGe +translateOp WordLeOp = Just mo_wordULe +translateOp WordGtOp = Just mo_wordUGt +translateOp WordLtOp = Just mo_wordULt + +translateOp WordMulOp = Just mo_wordMul +translateOp WordQuotOp = Just mo_wordUQuot +translateOp WordRemOp = Just mo_wordURem + +translateOp AddrGeOp = Just mo_wordUGe +translateOp AddrLeOp = Just mo_wordULe +translateOp AddrGtOp = Just mo_wordUGt +translateOp AddrLtOp = Just mo_wordULt + +-- 32-bit unsigned ops + +translateOp CharEqOp = Just (MO_Eq I32) +translateOp CharNeOp = Just (MO_Ne I32) +translateOp CharGeOp = Just (MO_U_Ge I32) +translateOp CharLeOp = Just (MO_U_Le I32) +translateOp CharGtOp = Just (MO_U_Gt I32) +translateOp CharLtOp = Just (MO_U_Lt I32) + +-- Double ops + +translateOp DoubleEqOp = Just (MO_Eq F64) +translateOp DoubleNeOp = Just (MO_Ne F64) +translateOp DoubleGeOp = Just (MO_S_Ge F64) +translateOp DoubleLeOp = Just (MO_S_Le F64) +translateOp DoubleGtOp = Just (MO_S_Gt F64) +translateOp DoubleLtOp = Just (MO_S_Lt F64) + +translateOp DoubleAddOp = Just (MO_Add F64) +translateOp DoubleSubOp = Just (MO_Sub F64) +translateOp DoubleMulOp = Just (MO_Mul F64) +translateOp DoubleDivOp = Just (MO_S_Quot F64) +translateOp DoubleNegOp = Just (MO_S_Neg F64) + +-- Float ops + +translateOp FloatEqOp = Just (MO_Eq F32) +translateOp FloatNeOp = Just (MO_Ne F32) +translateOp FloatGeOp = Just (MO_S_Ge F32) +translateOp FloatLeOp = Just (MO_S_Le F32) +translateOp FloatGtOp = Just (MO_S_Gt F32) +translateOp FloatLtOp = Just (MO_S_Lt F32) + +translateOp FloatAddOp = Just (MO_Add F32) +translateOp FloatSubOp = Just (MO_Sub F32) +translateOp FloatMulOp = Just (MO_Mul F32) +translateOp FloatDivOp = Just (MO_S_Quot F32) +translateOp FloatNegOp = Just (MO_S_Neg F32) + +-- Conversions + +translateOp Int2DoubleOp = Just (MO_S_Conv wordRep F64) +translateOp Double2IntOp = Just (MO_S_Conv F64 wordRep) + +translateOp Int2FloatOp = Just (MO_S_Conv wordRep F32) +translateOp Float2IntOp = Just (MO_S_Conv F32 wordRep) + +translateOp Float2DoubleOp = Just (MO_S_Conv F32 F64) +translateOp Double2FloatOp = Just (MO_S_Conv F64 F32) + +translateOp OrdOp = Just (MO_U_Conv I32 wordRep) +translateOp ChrOp = Just (MO_U_Conv wordRep I32) + +-- Word comparisons masquerading as more exotic things. + +translateOp SameMutVarOp = Just mo_wordEq +translateOp SameMVarOp = Just mo_wordEq +translateOp SameMutableArrayOp = Just mo_wordEq +translateOp SameMutableByteArrayOp = Just mo_wordEq +translateOp EqForeignObj = Just mo_wordEq +translateOp EqStablePtrOp = Just mo_wordEq + +translateOp _ = Nothing + +-- These primops are implemented by CallishMachOps, because they sometimes +-- turn into foreign calls depending on the backend. + +callishOp DoublePowerOp = Just MO_F64_Pwr +callishOp DoubleSinOp = Just MO_F64_Sin +callishOp DoubleCosOp = Just MO_F64_Cos +callishOp DoubleTanOp = Just MO_F64_Tan +callishOp DoubleSinhOp = Just MO_F64_Sinh +callishOp DoubleCoshOp = Just MO_F64_Cosh +callishOp DoubleTanhOp = Just MO_F64_Tanh +callishOp DoubleAsinOp = Just MO_F64_Asin +callishOp DoubleAcosOp = Just MO_F64_Acos +callishOp DoubleAtanOp = Just MO_F64_Atan +callishOp DoubleLogOp = Just MO_F64_Log +callishOp DoubleExpOp = Just MO_F64_Exp +callishOp DoubleSqrtOp = Just MO_F64_Sqrt + +callishOp FloatPowerOp = Just MO_F32_Pwr +callishOp FloatSinOp = Just MO_F32_Sin +callishOp FloatCosOp = Just MO_F32_Cos +callishOp FloatTanOp = Just MO_F32_Tan +callishOp FloatSinhOp = Just MO_F32_Sinh +callishOp FloatCoshOp = Just MO_F32_Cosh +callishOp FloatTanhOp = Just MO_F32_Tanh +callishOp FloatAsinOp = Just MO_F32_Asin +callishOp FloatAcosOp = Just MO_F32_Acos +callishOp FloatAtanOp = Just MO_F32_Atan +callishOp FloatLogOp = Just MO_F32_Log +callishOp FloatExpOp = Just MO_F32_Exp +callishOp FloatSqrtOp = Just MO_F32_Sqrt + +callishOp _ = Nothing + +------------------------------------------------------------------------------ +-- Helpers for translating various minor variants of array indexing. + +doIndexOffForeignObjOp maybe_post_read_cast rep [res] [addr,idx] + = mkBasicIndexedRead 0 maybe_post_read_cast rep res + (cmmLoadIndexW addr fixedHdrSize) idx +doIndexOffForeignObjOp _ _ _ _ + = panic "CgPrimOp: doIndexOffForeignObjOp" + +doIndexOffAddrOp maybe_post_read_cast rep [res] [addr,idx] + = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr idx +doIndexOffAddrOp _ _ _ _ + = panic "CgPrimOp: doIndexOffAddrOp" + +doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx] + = mkBasicIndexedRead arrWordsHdrSize maybe_post_read_cast rep res addr idx +doIndexByteArrayOp _ _ _ _ + = panic "CgPrimOp: doIndexByteArrayOp" + +doReadPtrArrayOp res addr idx + = mkBasicIndexedRead arrPtrsHdrSize Nothing wordRep res addr idx + + +doWriteOffAddrOp maybe_pre_write_cast rep [] [addr,idx,val] + = mkBasicIndexedWrite 0 maybe_pre_write_cast rep addr idx val +doWriteOffAddrOp _ _ _ _ + = panic "CgPrimOp: doWriteOffAddrOp" + +doWriteByteArrayOp maybe_pre_write_cast rep [] [addr,idx,val] + = mkBasicIndexedWrite arrWordsHdrSize maybe_pre_write_cast rep addr idx val +doWriteByteArrayOp _ _ _ _ + = panic "CgPrimOp: doWriteByteArrayOp" + +doWritePtrArrayOp addr idx val + = mkBasicIndexedWrite arrPtrsHdrSize Nothing wordRep addr idx val + + +mkBasicIndexedRead off Nothing read_rep res base idx + = stmtC (CmmAssign res (cmmLoadIndexOffExpr off read_rep base idx)) +mkBasicIndexedRead off (Just cast) read_rep res base idx + = stmtC (CmmAssign res (CmmMachOp cast [ + cmmLoadIndexOffExpr off read_rep base idx])) + +mkBasicIndexedWrite off Nothing write_rep base idx val + = stmtC (CmmStore (cmmIndexOffExpr off write_rep base idx) val) +mkBasicIndexedWrite off (Just cast) write_rep base idx val + = stmtC (CmmStore (cmmIndexOffExpr off write_rep base idx) (CmmMachOp cast [val])) + +-- ---------------------------------------------------------------------------- +-- Misc utils + +cmmIndexOffExpr :: ByteOff -> MachRep -> CmmExpr -> CmmExpr -> CmmExpr +cmmIndexOffExpr off rep base idx + = cmmIndexExpr rep (cmmOffsetB base off) idx + +cmmLoadIndexOffExpr :: ByteOff -> MachRep -> CmmExpr -> CmmExpr -> CmmExpr +cmmLoadIndexOffExpr off rep base idx + = CmmLoad (cmmIndexOffExpr off rep base idx) rep + +setInfo :: CmmExpr -> CmmExpr -> CmmStmt +setInfo closure_ptr info_ptr = CmmStore closure_ptr info_ptr + diff --git a/ghc/compiler/codeGen/CgProf.hs b/ghc/compiler/codeGen/CgProf.hs new file mode 100644 index 0000000000..30f801dba3 --- /dev/null +++ b/ghc/compiler/codeGen/CgProf.hs @@ -0,0 +1,474 @@ +----------------------------------------------------------------------------- +-- +-- Code generation for profiling +-- +-- (c) The University of Glasgow 2004 +-- +----------------------------------------------------------------------------- + +module CgProf ( + mkCCostCentre, mkCCostCentreStack, + + -- Cost-centre Profiling + dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf, + enterCostCentre, enterCostCentrePAP, enterCostCentreThunk, + chooseDynCostCentres, + costCentreFrom, + curCCS, curCCSAddr, + emitCostCentreDecl, emitCostCentreStackDecl, + emitRegisterCC, emitRegisterCCS, + emitSetCCC, emitCCS, + + -- Lag/drag/void stuff + ldvEnter, ldvRecordCreate + ) where + +#include "HsVersions.h" +#include "../includes/ghcconfig.h" + -- Needed by Constants.h +#include "../includes/Constants.h" + -- For LDV_CREATE_MASK, LDV_STATE_USE + -- which are StgWords +#include "../includes/DerivedConstants.h" + -- For REP_xxx constants, which are MachReps + +import ClosureInfo ( ClosureInfo, closureSize, + closureName, isToplevClosure, closureReEntrant, ) +import CgUtils +import CgMonad +import SMRep ( StgWord, profHdrSize ) + +import Cmm +import MachOp +import CmmUtils ( zeroCLit, mkIntCLit, mkLblExpr ) +import CLabel ( mkCCLabel, mkCCSLabel, mkRtsDataLabel ) + +import Module ( moduleNameUserString ) +import Id ( Id ) +import CostCentre +import StgSyn ( GenStgExpr(..), StgExpr ) +import CmdLineOpts ( opt_SccProfilingOn ) +import FastString ( FastString, mkFastString, LitString ) +import Constants -- Lots of field offsets +import Outputable + +import Maybe +import Char ( ord ) +import Monad ( when ) + +----------------------------------------------------------------------------- +-- +-- Cost-centre-stack Profiling +-- +----------------------------------------------------------------------------- + +-- Expression representing the current cost centre stack +curCCS :: CmmExpr +curCCS = CmmLoad curCCSAddr wordRep + +-- Address of current CCS variable, for storing into +curCCSAddr :: CmmExpr +curCCSAddr = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CCCS"))) + +mkCCostCentre :: CostCentre -> CmmLit +mkCCostCentre cc = CmmLabel (mkCCLabel cc) + +mkCCostCentreStack :: CostCentreStack -> CmmLit +mkCCostCentreStack ccs = CmmLabel (mkCCSLabel ccs) + +costCentreFrom :: CmmExpr -- A closure pointer + -> CmmExpr -- The cost centre from that closure +costCentreFrom cl = CmmLoad (cmmOffsetB cl oFFSET_StgHeader_ccs) wordRep + +staticProfHdr :: CostCentreStack -> [CmmLit] +-- The profiling header words in a static closure +-- Was SET_STATIC_PROF_HDR +staticProfHdr ccs = ifProfilingL [mkCCostCentreStack ccs, + staticLdvInit] + +dynProfHdr :: CmmExpr -> [CmmExpr] +-- Profiling header words in a dynamic closure +dynProfHdr ccs = ifProfilingL [ccs, dynLdvInit] + +initUpdFrameProf :: CmmExpr -> Code +-- Initialise the profiling field of an update frame +initUpdFrameProf frame_amode + = ifProfiling $ -- frame->header.prof.ccs = CCCS + stmtC (CmmStore (cmmOffsetB frame_amode oFFSET_StgHeader_ccs) curCCS) + -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0) + -- is unnecessary because it is not used anyhow. + +-- ----------------------------------------------------------------------------- +-- Recording allocation in a cost centre + +-- | Record the allocation of a closure. The CmmExpr is the cost +-- centre stack to which to attribute the allocation. +profDynAlloc :: ClosureInfo -> CmmExpr -> Code +profDynAlloc cl_info ccs + = ifProfiling $ + profAlloc (CmmLit (mkIntCLit (closureSize cl_info))) ccs + +-- | Record the allocation of a closure (size is given by a CmmExpr) +-- The size must be in words, because the allocation counter in a CCS counts +-- in words. +profAlloc :: CmmExpr -> CmmExpr -> Code +profAlloc words ccs + = ifProfiling $ + stmtC (addToMemE alloc_rep + (cmmOffsetB ccs oFFSET_CostCentreStack_mem_alloc) + (CmmMachOp (MO_U_Conv wordRep alloc_rep) $ + [CmmMachOp mo_wordSub [words, + CmmLit (mkIntCLit profHdrSize)]])) + -- subtract the "profiling overhead", which is the + -- profiling header in a closure. + where + alloc_rep = REP_CostCentreStack_mem_alloc + +-- ---------------------------------------------------------------------- +-- Setting the cost centre in a new closure + +chooseDynCostCentres :: CostCentreStack + -> [Id] -- Args + -> StgExpr -- Body + -> FCode (CmmExpr, CmmExpr) +-- Called when alllcating a closure +-- Tells which cost centre to put in the object, and which +-- to blame the cost of allocation on +chooseDynCostCentres ccs args body = do + -- Cost-centre we record in the object + use_ccs <- emitCCS ccs + + -- Cost-centre on whom we blame the allocation + let blame_ccs + | null args && isBox body = CmmLit (mkCCostCentreStack overheadCCS) + | otherwise = use_ccs + + return (use_ccs, blame_ccs) + + +-- Some CostCentreStacks are a sequence of pushes on top of CCCS. +-- These pushes must be performed before we can refer to the stack in +-- an expression. +emitCCS :: CostCentreStack -> FCode CmmExpr +emitCCS ccs = push_em (ccsExpr ccs') (reverse cc's) + where + (cc's, ccs') = decomposeCCS ccs + + push_em ccs [] = return ccs + push_em ccs (cc:rest) = do + tmp <- newTemp wordRep + pushCostCentre tmp ccs cc + push_em (CmmReg tmp) rest + +ccsExpr :: CostCentreStack -> CmmExpr +ccsExpr ccs + | isCurrentCCS ccs = curCCS + | otherwise = CmmLit (mkCCostCentreStack ccs) + + +isBox :: StgExpr -> Bool +-- If it's an utterly trivial RHS, then it must be +-- one introduced by boxHigherOrderArgs for profiling, +-- so we charge it to "OVERHEAD". +-- This looks like a GROSS HACK to me --SDM +isBox (StgApp fun []) = True +isBox other = False + + +-- ----------------------------------------------------------------------- +-- Setting the current cost centre on entry to a closure + +-- For lexically scoped profiling we have to load the cost centre from +-- the closure entered, if the costs are not supposed to be inherited. +-- This is done immediately on entering the fast entry point. + +-- Load current cost centre from closure, if not inherited. +-- Node is guaranteed to point to it, if profiling and not inherited. + +enterCostCentre + :: ClosureInfo + -> CostCentreStack + -> StgExpr -- The RHS of the closure + -> Code + +-- We used to have a special case for bindings of form +-- f = g True +-- where g has arity 2. The RHS is a thunk, but we don't +-- need to update it; and we want to subsume costs. +-- We don't have these sort of PAPs any more, so the special +-- case has gone away. + +enterCostCentre closure_info ccs body + = ifProfiling $ + ASSERT2(not (noCCSAttached ccs), ppr (closureName closure_info) <+> ppr ccs) + enter_cost_centre closure_info ccs body + +enter_cost_centre closure_info ccs body + | isSubsumedCCS ccs + = ASSERT(isToplevClosure closure_info) + ASSERT(re_entrant) + enter_ccs_fsub + + | isDerivedFromCurrentCCS ccs + = do { + if re_entrant && not is_box + then + enter_ccs_fun node_ccs + else + stmtC (CmmStore curCCSAddr node_ccs) + + -- don't forget to bump the scc count. This closure might have been + -- of the form let x = _scc_ "x" e in ...x..., which the SCCfinal + -- pass has turned into simply let x = e in ...x... and attached + -- the _scc_ as PushCostCentre(x,CCCS) on the x closure. So that + -- we don't lose the scc counter, bump it in the entry code for x. + -- ToDo: for a multi-push we should really bump the counter for + -- each of the intervening CCSs, not just the top one. + ; when (not (isCurrentCCS ccs)) $ + stmtC (bumpSccCount curCCS) + } + + | isCafCCS ccs + = ASSERT(isToplevClosure closure_info) + ASSERT(not re_entrant) + do { -- This is just a special case of the isDerivedFromCurrentCCS + -- case above. We could delete this, but it's a micro + -- optimisation and saves a bit of code. + stmtC (CmmStore curCCSAddr enc_ccs) + ; stmtC (bumpSccCount node_ccs) + } + + | otherwise + = panic "enterCostCentre" + where + enc_ccs = CmmLit (mkCCostCentreStack ccs) + re_entrant = closureReEntrant closure_info + node_ccs = costCentreFrom (CmmReg nodeReg) + is_box = isBox body + +-- set the current CCS when entering a PAP +enterCostCentrePAP :: CmmExpr -> Code +enterCostCentrePAP closure = + ifProfiling $ do + enter_ccs_fun (costCentreFrom closure) + enteringPAP 1 + +enterCostCentreThunk :: CmmExpr -> Code +enterCostCentreThunk closure = + ifProfiling $ do + stmtC $ CmmStore curCCSAddr (costCentreFrom closure) + +enter_ccs_fun stack = emitRtsCall SLIT("EnterFunCCS") [(stack,PtrHint)] + +enter_ccs_fsub = enteringPAP 0 + +-- When entering a PAP, EnterFunCCS is called by both the PAP entry +-- code and the function entry code; we don't want the function's +-- entry code to also update CCCS in the event that it was called via +-- a PAP, so we set the flag entering_PAP to indicate that we are +-- entering via a PAP. +enteringPAP :: Integer -> Code +enteringPAP n + = stmtC (CmmStore (CmmLit (CmmLabel (mkRtsDataLabel SLIT("entering_PAP")))) + (CmmLit (CmmInt n cIntRep))) + +ifProfiling :: Code -> Code +ifProfiling code + | opt_SccProfilingOn = code + | otherwise = nopC + +ifProfilingL :: [a] -> [a] +ifProfilingL xs + | opt_SccProfilingOn = xs + | otherwise = [] + + +-- --------------------------------------------------------------------------- +-- Initialising Cost Centres & CCSs + +emitCostCentreDecl + :: CostCentre + -> Code +emitCostCentreDecl cc = do + { label <- mkStringCLit (costCentreUserName cc) + ; modl <- mkStringCLit (moduleNameUserString (cc_mod cc)) + ; let + lits = [ zero, -- StgInt ccID, + label, -- char *label, + modl, -- char *module, + zero, -- StgWord time_ticks + zero64, -- StgWord64 mem_alloc + subsumed, -- StgInt is_caf + zero -- struct _CostCentre *link + ] + ; emitDataLits (mkCCLabel cc) lits + } + where + subsumed | isCafCC cc = mkIntCLit (ord 'c') -- 'c' == is a CAF + | otherwise = mkIntCLit (ord 'B') -- 'B' == is boring + + +emitCostCentreStackDecl + :: CostCentreStack + -> Code +emitCostCentreStackDecl ccs + | Just cc <- maybeSingletonCCS ccs = do + { let + lits = [ zero, + mkCCostCentre cc, + zero, -- struct _CostCentreStack *prevStack; + zero, -- struct _IndexTable *indexTable; + zero, -- StgWord selected; + zero64, -- StgWord64 scc_count; + zero, -- StgWord time_ticks; + zero64, -- StgWord64 mem_alloc; + zero, -- StgWord inherited_ticks; + zero64, -- StgWord64 inherited_alloc; + zero -- CostCentre *root; + ] + ; emitDataLits (mkCCSLabel ccs) lits + } + | otherwise = pprPanic "emitCostCentreStackDecl" (ppr ccs) + +zero = mkIntCLit 0 +zero64 = CmmInt 0 I64 + + +-- --------------------------------------------------------------------------- +-- Registering CCs and CCSs + +-- (cc)->link = CC_LIST; +-- CC_LIST = (cc); +-- (cc)->ccID = CC_ID++; + +emitRegisterCC :: CostCentre -> Code +emitRegisterCC cc = do + { tmp <- newTemp cIntRep + ; stmtsC [ + CmmStore (cmmOffsetB cc_lit oFFSET_CostCentre_link) + (CmmLoad cC_LIST wordRep), + CmmStore cC_LIST cc_lit, + CmmAssign tmp (CmmLoad cC_ID cIntRep), + CmmStore (cmmOffsetB cc_lit oFFSET_CostCentre_ccID) (CmmReg tmp), + CmmStore cC_ID (cmmRegOffB tmp 1) + ] + } + where + cc_lit = CmmLit (CmmLabel (mkCCLabel cc)) + +-- (ccs)->prevStack = CCS_LIST; +-- CCS_LIST = (ccs); +-- (ccs)->ccsID = CCS_ID++; + +emitRegisterCCS :: CostCentreStack -> Code +emitRegisterCCS ccs = do + { tmp <- newTemp cIntRep + ; stmtsC [ + CmmStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_prevStack) + (CmmLoad cCS_LIST wordRep), + CmmStore cCS_LIST ccs_lit, + CmmAssign tmp (CmmLoad cCS_ID cIntRep), + CmmStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_ccsID) (CmmReg tmp), + CmmStore cCS_ID (cmmRegOffB tmp 1) + ] + } + where + ccs_lit = CmmLit (CmmLabel (mkCCSLabel ccs)) + + +cC_LIST = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CC_LIST"))) +cC_ID = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CC_ID"))) + +cCS_LIST = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CCS_LIST"))) +cCS_ID = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CCS_ID"))) + +-- --------------------------------------------------------------------------- +-- Set the current cost centre stack + +emitSetCCC :: CostCentre -> Code +emitSetCCC cc + | not opt_SccProfilingOn = nopC + | otherwise = do + ASSERTM(sccAbleCostCentre cc) + tmp <- newTemp wordRep + pushCostCentre tmp curCCS cc + stmtC (CmmStore curCCSAddr (CmmReg tmp)) + when (isSccCountCostCentre cc) $ + stmtC (bumpSccCount curCCS) + +pushCostCentre :: CmmReg -> CmmExpr -> CostCentre -> Code +pushCostCentre result ccs cc + = emitRtsCallWithResult result PtrHint + SLIT("PushCostCentre") [(ccs,PtrHint), + (CmmLit (mkCCostCentre cc), PtrHint)] + +bumpSccCount :: CmmExpr -> CmmStmt +bumpSccCount ccs + = addToMem REP_CostCentreStack_scc_count + (cmmOffsetB ccs oFFSET_CostCentreStack_scc_count) 1 + +----------------------------------------------------------------------------- +-- +-- Lag/drag/void stuff +-- +----------------------------------------------------------------------------- + +-- +-- Initial value for the LDV field in a static closure +-- +staticLdvInit :: CmmLit +staticLdvInit = zeroCLit + +-- +-- Initial value of the LDV field in a dynamic closure +-- +dynLdvInit :: CmmExpr +dynLdvInit = -- (era << LDV_SHIFT) | LDV_STATE_CREATE + CmmMachOp mo_wordOr [ + CmmMachOp mo_wordShl [loadEra, CmmLit (mkIntCLit lDV_SHIFT) ], + CmmLit (mkWordCLit lDV_STATE_CREATE) + ] + +-- +-- Initialise the LDV word of a new closure +-- +ldvRecordCreate :: CmmExpr -> Code +ldvRecordCreate closure = stmtC $ CmmStore (ldvWord closure) dynLdvInit + +-- +-- Called when a closure is entered, marks the closure as having been "used". +-- The closure is not an 'inherently used' one. +-- The closure is not IND or IND_OLDGEN because neither is considered for LDV +-- profiling. +-- +ldvEnter :: CmmExpr -> Code +-- Argument is a closure pointer +ldvEnter cl_ptr + = ifProfiling $ + -- if (era > 0) { + -- LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) | + -- era | LDV_STATE_USE } + emitIf (CmmMachOp mo_wordUGt [loadEra, CmmLit zeroCLit]) + (stmtC (CmmStore ldv_wd new_ldv_wd)) + where + ldv_wd = ldvWord cl_ptr + new_ldv_wd = cmmOrWord (cmmAndWord (CmmLoad ldv_wd wordRep) + (CmmLit (mkWordCLit lDV_CREATE_MASK))) + (cmmOrWord loadEra (CmmLit (mkWordCLit lDV_STATE_USE))) + +loadEra :: CmmExpr +loadEra = CmmLoad (mkLblExpr (mkRtsDataLabel SLIT("era"))) cIntRep + +ldvWord :: CmmExpr -> CmmExpr +-- Takes the address of a closure, and returns +-- the address of the LDV word in the closure +ldvWord closure_ptr = cmmOffsetB closure_ptr oFFSET_StgHeader_ldvw + +-- LDV constants, from ghc/includes/Constants.h +lDV_SHIFT = (LDV_SHIFT :: Int) +--lDV_STATE_MASK = (LDV_STATE_MASK :: StgWord) +lDV_CREATE_MASK = (LDV_CREATE_MASK :: StgWord) +--lDV_LAST_MASK = (LDV_LAST_MASK :: StgWord) +lDV_STATE_CREATE = (LDV_STATE_CREATE :: StgWord) +lDV_STATE_USE = (LDV_STATE_USE :: StgWord) + diff --git a/ghc/compiler/codeGen/CgRetConv.hi-boot b/ghc/compiler/codeGen/CgRetConv.hi-boot deleted file mode 100644 index 9b14f430ab..0000000000 --- a/ghc/compiler/codeGen/CgRetConv.hi-boot +++ /dev/null @@ -1,7 +0,0 @@ -_interface_ CgRetConv 1 -_exports_ -CgRetConv CtrlReturnConvention(VectoredReturn UnvectoredReturn) ctrlReturnConvAlg; -_declarations_ -1 data CtrlReturnConvention = VectoredReturn PrelBase.Int | UnvectoredReturn PrelBase.Int; -1 ctrlReturnConvAlg _:_ TyCon.TyCon -> CtrlReturnConvention ;; - diff --git a/ghc/compiler/codeGen/CgRetConv.lhs b/ghc/compiler/codeGen/CgRetConv.lhs deleted file mode 100644 index ecf7d52ae9..0000000000 --- a/ghc/compiler/codeGen/CgRetConv.lhs +++ /dev/null @@ -1,246 +0,0 @@ -% -% (c) The GRASP Project, Glasgow University, 1992-1998 -% -% $Id: CgRetConv.lhs,v 1.34 2003/10/09 11:58:46 simonpj Exp $ -% -\section[CgRetConv]{Return conventions for the code generator} - -The datatypes and functions here encapsulate what there is to know -about return conventions. - -\begin{code} -module CgRetConv ( - CtrlReturnConvention(..), - ctrlReturnConvAlg, - dataReturnConvPrim, - assignRegs, assignAllRegs - ) where - -#include "HsVersions.h" - -import AbsCSyn -- quite a few things -import Constants ( mAX_FAMILY_SIZE_FOR_VEC_RETURNS, - mAX_Vanilla_REG, mAX_Float_REG, - mAX_Double_REG, mAX_Long_REG, - mAX_Real_Vanilla_REG, mAX_Real_Float_REG, - mAX_Real_Double_REG, mAX_Real_Long_REG - ) -import CmdLineOpts ( opt_Unregisterised ) -import Maybes ( mapCatMaybes ) -import PrimRep ( isFloatingRep, PrimRep(..), is64BitRep ) -import TyCon ( TyCon, tyConFamilySize ) -import Util ( isn'tIn ) -import FastTypes -import Outputable -\end{code} - -%************************************************************************ -%* * -\subsection[CgRetConv-possibilities]{Data types that encode possible return conventions} -%* * -%************************************************************************ - -A @CtrlReturnConvention@ says how {\em control} is returned. -\begin{code} -data CtrlReturnConvention - = VectoredReturn Int -- size of the vector table (family size) - | UnvectoredReturn Int -- family size -\end{code} - -%************************************************************************ -%* * -\subsection[CgRetConv-algebraic]{Return conventions for algebraic datatypes} -%* * -%************************************************************************ - -\begin{code} -ctrlReturnConvAlg :: TyCon -> CtrlReturnConvention - -ctrlReturnConvAlg tycon - = case (tyConFamilySize tycon) of - size -> -- we're supposed to know... - if (size > (1::Int) && size <= mAX_FAMILY_SIZE_FOR_VEC_RETURNS) then - VectoredReturn size - else - UnvectoredReturn size - -- NB: unvectored returns Include size 0 (no constructors), so that - -- the following perverse code compiles (it crashed GHC in 5.02) - -- data T1 - -- data T2 = T2 !T1 Int - -- The only value of type T1 is bottom, which never returns anyway. -\end{code} - -%************************************************************************ -%* * -\subsection[CgRetConv-prim]{Return conventions for primitive datatypes} -%* * -%************************************************************************ - -\begin{code} -dataReturnConvPrim :: PrimRep -> MagicId - -dataReturnConvPrim PtrRep = VanillaReg PtrRep (_ILIT 1) -dataReturnConvPrim IntRep = VanillaReg IntRep (_ILIT 1) -dataReturnConvPrim WordRep = VanillaReg WordRep (_ILIT 1) -dataReturnConvPrim Int32Rep = VanillaReg Int32Rep (_ILIT 1) -dataReturnConvPrim Word32Rep = VanillaReg Word32Rep (_ILIT 1) -dataReturnConvPrim Int64Rep = LongReg Int64Rep (_ILIT 1) -dataReturnConvPrim Word64Rep = LongReg Word64Rep (_ILIT 1) -dataReturnConvPrim AddrRep = VanillaReg AddrRep (_ILIT 1) -dataReturnConvPrim CharRep = VanillaReg CharRep (_ILIT 1) -dataReturnConvPrim Int8Rep = VanillaReg Int8Rep (_ILIT 1) -dataReturnConvPrim FloatRep = FloatReg (_ILIT 1) -dataReturnConvPrim DoubleRep = DoubleReg (_ILIT 1) -dataReturnConvPrim StablePtrRep = VanillaReg StablePtrRep (_ILIT 1) -dataReturnConvPrim VoidRep = VoidReg - -#ifdef DEBUG -dataReturnConvPrim rep = pprPanic "dataReturnConvPrim:" (ppr rep) -#endif -\end{code} - -%************************************************************************ -%* * -\subsubsection[CgRetConv-regs]{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. - -\begin{code} -assignRegs, assignAllRegs - :: [MagicId] -- Unavailable registers - -> [PrimRep] -- Arg or result kinds to assign - -> ([MagicId], -- Register assignment in same order - -- for *initial segment of* input list - [PrimRep])-- leftover kinds - -assignRegs regs_in_use kinds - = assign_reg kinds [] (mkRegTbl regs_in_use) - -assignAllRegs regs_in_use kinds - = assign_reg kinds [] (mkRegTbl_allRegs regs_in_use) - -assign_reg - :: [PrimRep] -- arg kinds being scrutinized - -> [MagicId] -- accum. regs assigned so far (reversed) - -> AvailRegs -- regs still avail: Vanilla, Float, Double, longs - -> ([MagicId], [PrimRep]) - -assign_reg (VoidRep:ks) acc supply - = assign_reg ks (VoidReg:acc) supply - -- one VoidReg is enough for everybody! - -assign_reg (FloatRep:ks) acc (vanilla_rs, f:float_rs, double_rs, long_rs) - = assign_reg ks (FloatReg (iUnbox f):acc) - (vanilla_rs, float_rs, double_rs, long_rs) - -assign_reg (DoubleRep:ks) acc (vanilla_rs, float_rs, d:double_rs, long_rs) - = assign_reg ks (DoubleReg (iUnbox d):acc) - (vanilla_rs, float_rs, double_rs, long_rs) - -assign_reg (Word64Rep:ks) acc (vanilla_rs, float_rs, double_rs, u:long_rs) - = assign_reg ks (LongReg Word64Rep (iUnbox u):acc) - (vanilla_rs, float_rs, double_rs, long_rs) - -assign_reg (Int64Rep:ks) acc (vanilla_rs, float_rs, double_rs, l:long_rs) - = assign_reg ks (LongReg Int64Rep (iUnbox l):acc) - (vanilla_rs, float_rs, double_rs, long_rs) - -assign_reg (k:ks) acc (v:vanilla_rs, float_rs, double_rs, long_rs) - | not (isFloatingRep k || is64BitRep k) - = assign_reg ks (VanillaReg k (iUnbox v):acc) - (vanilla_rs, float_rs, double_rs, long_rs) - --- The catch-all. It can happen because either --- (a) we've assigned all the regs so leftover_ks is [] --- (b) we couldn't find a spare register in the appropriate supply --- or, I suppose, --- (c) we came across a Kind we couldn't handle (this one shouldn't happen) -assign_reg leftover_ks acc _ = (reverse acc, leftover_ks) - -\end{code} - -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. - -\begin{code} -useVanillaRegs | opt_Unregisterised = 0 - | otherwise = mAX_Real_Vanilla_REG -useFloatRegs | opt_Unregisterised = 0 - | otherwise = mAX_Real_Float_REG -useDoubleRegs | opt_Unregisterised = 0 - | otherwise = mAX_Real_Double_REG -useLongRegs | opt_Unregisterised = 0 - | otherwise = mAX_Real_Long_REG - -vanillaRegNos, floatRegNos, doubleRegNos, longRegNos :: [Int] -vanillaRegNos = regList useVanillaRegs -floatRegNos = regList useFloatRegs -doubleRegNos = regList useDoubleRegs -longRegNos = regList useLongRegs - -allVanillaRegNos, allFloatRegNos, allDoubleRegNos, allLongRegNos :: [Int] -allVanillaRegNos = regList mAX_Vanilla_REG -allFloatRegNos = regList mAX_Float_REG -allDoubleRegNos = regList mAX_Double_REG -allLongRegNos = regList mAX_Long_REG - -regList 0 = [] -regList n = [1 .. n] - -type AvailRegs = ( [Int] -- available vanilla regs. - , [Int] -- floats - , [Int] -- doubles - , [Int] -- longs (int64 and word64) - ) - -mkRegTbl :: [MagicId] -> AvailRegs -mkRegTbl regs_in_use - = mkRegTbl' regs_in_use vanillaRegNos floatRegNos doubleRegNos longRegNos - -mkRegTbl_allRegs :: [MagicId] -> AvailRegs -mkRegTbl_allRegs regs_in_use - = mkRegTbl' regs_in_use allVanillaRegNos allFloatRegNos allDoubleRegNos allLongRegNos - -mkRegTbl' regs_in_use vanillas floats doubles longs - = (ok_vanilla, ok_float, ok_double, ok_long) - where - ok_vanilla = mapCatMaybes (select (VanillaReg VoidRep)) vanillas - ok_float = mapCatMaybes (select FloatReg) floats - ok_double = mapCatMaybes (select DoubleReg) doubles - ok_long = mapCatMaybes (select (LongReg Int64Rep)) longs - -- rep isn't looked at, hence we can use any old rep. - - select :: (FastInt -> MagicId) -> Int{-cand-} -> Maybe Int - -- one we've unboxed the Int, we make a MagicId - -- and see if it is already in use; if not, return its number. - - select mk_reg_fun cand - = let - reg = mk_reg_fun (iUnbox cand) - in - if reg `not_elem` regs_in_use - then Just cand - else Nothing - where - not_elem = isn'tIn "mkRegTbl" -\end{code} diff --git a/ghc/compiler/codeGen/CgStackery.lhs b/ghc/compiler/codeGen/CgStackery.lhs index 4b1b414064..206dcc2153 100644 --- a/ghc/compiler/codeGen/CgStackery.lhs +++ b/ghc/compiler/codeGen/CgStackery.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgStackery.lhs,v 1.24 2003/11/17 14:42:47 simonmar Exp $ +% $Id: CgStackery.lhs,v 1.25 2004/08/13 13:06:12 simonmar Exp $ % \section[CgStackery]{Stack management functions} @@ -10,33 +10,92 @@ Stack-twiddling operations, which are pretty low-down and grimy. \begin{code} module CgStackery ( + spRel, getVirtSp, getRealSp, setRealSp, + setRealAndVirtualSp, getSpRelOffset, + allocPrimStack, allocStackTop, deAllocStackTop, adjustStackHW, getFinalStackHW, setStackFrame, getStackFrame, mkVirtStkOffsets, mkStkAmodes, - freeStackSlots, dataStackSlots, - updateFrameSize, - constructSlowCall, slowArgs, + freeStackSlots, + pushUpdateFrame, emitPushUpdateFrame, ) where #include "HsVersions.h" import CgMonad -import AbsCSyn -import CLabel ( mkRtsApplyInfoLabel, mkRtsApplyEntryLabel ) - -import CgUsages ( getRealSp ) -import AbsCUtils ( mkAbstractCs, getAmodeRep ) -import PrimRep -import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros ) +import CgUtils ( cmmOffsetB, cmmRegOffW ) +import CgProf ( initUpdFrameProf ) +import SMRep +import Cmm +import CmmUtils ( CmmStmts, mkLblExpr ) +import CLabel ( mkUpdInfoLabel ) import Constants import Util ( sortLt ) import FastString ( LitString ) -import Panic - -import TRACE ( trace ) +import OrdList ( toOL ) +import Outputable +\end{code} + +%************************************************************************ +%* * +\subsection[CgUsages-stackery]{Monad things for fiddling with stack usage} +%* * +%************************************************************************ + +spRel is a little function that abstracts the stack direction. Note that most +of the code generator is dependent on the stack direction anyway, so +changing this on its own spells certain doom. ToDo: remove? + + THIS IS DIRECTION SENSITIVE! + +Stack grows down, positive virtual offsets correspond to negative +additions to the stack pointer. + +\begin{code} +spRel :: VirtualSpOffset -- virtual offset of Sp + -> VirtualSpOffset -- virtual offset of The Thing + -> WordOff -- integer offset +spRel sp off = sp - off +\end{code} + +@setRealAndVirtualSp@ sets into the environment the offsets of the +current position of the real and virtual stack pointers in the current +stack frame. The high-water mark is set too. It generates no code. +It is used to initialise things at the beginning of a closure body. + +\begin{code} +setRealAndVirtualSp :: VirtualSpOffset -- New real Sp + -> Code + +setRealAndVirtualSp new_sp + = do { stk_usg <- getStkUsage + ; setStkUsage (stk_usg {virtSp = new_sp, + realSp = new_sp, + hwSp = new_sp}) } + +getVirtSp :: FCode VirtualSpOffset +getVirtSp + = do { stk_usg <- getStkUsage + ; return (virtSp stk_usg) } + +getRealSp :: FCode VirtualSpOffset +getRealSp + = do { stk_usg <- getStkUsage + ; return (realSp stk_usg) } + +setRealSp :: VirtualSpOffset -> Code +setRealSp new_real_sp + = do { stk_usg <- getStkUsage + ; setStkUsage (stk_usg {realSp = new_real_sp}) } + +getSpRelOffset :: VirtualSpOffset -> FCode CmmExpr +getSpRelOffset virtual_offset + = do { real_sp <- getRealSp + ; return (cmmRegOffW spReg (spRel real_sp virtual_offset)) } \end{code} + %************************************************************************ %* * \subsection[CgStackery-layout]{Laying out a stack frame} @@ -50,24 +109,22 @@ increase towards the top of stack). \begin{code} mkVirtStkOffsets :: VirtualSpOffset -- Offset of the last allocated thing - -> (a -> PrimRep) -- to be able to grab kinds - -> [a] -- things to make offsets for + -> [(CgRep,a)] -- things to make offsets for -> (VirtualSpOffset, -- OUTPUTS: Topmost allocated word - [(a, VirtualSpOffset)]) -- things with offsets + [(a, VirtualSpOffset)]) -- things with offsets (voids filtered out) -mkVirtStkOffsets init_Sp_offset kind_fun things +mkVirtStkOffsets init_Sp_offset things = loop init_Sp_offset [] (reverse things) where loop offset offs [] = (offset,offs) - loop offset offs (t:things) = - let - size = getPrimRepSize (kind_fun t) - thing_slot = offset + size - in - loop thing_slot ((t,thing_slot):offs) things - -- offset of thing is offset+size, because we're growing the stack - -- *downwards* as the offsets increase. - + loop offset offs ((VoidArg,t):things) = loop offset offs things + -- ignore Void arguments + loop offset offs ((rep,t):things) + = loop thing_slot ((t,thing_slot):offs) things + where + thing_slot = offset + cgRepSizeW rep + -- offset of thing is offset+size, because we're + -- growing the stack *downwards* as the offsets increase. -- | 'mkStkAmodes' is a higher-level version of -- 'mkVirtStkOffsets'. It starts from the tail-call locations. @@ -77,87 +134,17 @@ mkVirtStkOffsets init_Sp_offset kind_fun things mkStkAmodes :: VirtualSpOffset -- Tail call positions - -> [CAddrMode] -- things to make offsets for + -> [(CgRep,CmmExpr)] -- things to make offsets for -> FCode (VirtualSpOffset, -- OUTPUTS: Topmost allocated word - AbstractC) -- Assignments to appropriate stk slots + CmmStmts) -- Assignments to appropriate stk slots mkStkAmodes tail_Sp things - = getRealSp `thenFC` \ realSp -> - let - (last_Sp_offset, offsets) = mkVirtStkOffsets tail_Sp getAmodeRep things - - abs_cs = - [ CAssign (CVal (spRel realSp offset) (getAmodeRep thing)) thing - | (thing, offset) <- offsets - ] - in - returnFC (last_Sp_offset, mkAbstractCs abs_cs) -\end{code} - -%************************************************************************ -%* * -\subsection{Pushing the arguments for a slow call} -%* * -%************************************************************************ - -For a slow call, we must take a bunch of arguments and intersperse -some stg_ap__ret_info return addresses. - -\begin{code} -constructSlowCall :: [CAddrMode] -> (CAddrMode, [CAddrMode]) - -- don't forget the zero case -constructSlowCall [] = (CLbl stg_ap_0 CodePtrRep , []) -constructSlowCall amodes = - -- traceSlowCall amodes $ - (CLbl lbl CodePtrRep, these ++ slowArgs rest) - where (tag, these, rest) = matchSlowPattern amodes - lbl = mkRtsApplyEntryLabel tag - -stg_ap_0 = mkRtsApplyEntryLabel SLIT("0") - --- | '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 :: [CAddrMode] -> [CAddrMode] -slowArgs [] = [] -slowArgs amodes = CLbl lbl RetRep : args ++ slowArgs rest - where (tag, args, rest) = matchSlowPattern amodes - lbl = mkRtsApplyInfoLabel tag - -matchSlowPattern :: [CAddrMode] -> (LitString, [CAddrMode], [CAddrMode]) -matchSlowPattern amodes = (tag, these, rest) - where reps = map getAmodeRep amodes - (tag, n) = findMatch (map primRepToArgRep reps) - (these, rest) = splitAt n amodes - --- These cases were found to cover about 99% of all slow calls: -findMatch (RepP: RepP: RepP: RepP: RepP: RepP: RepP: _) = (SLIT("ppppppp"), 7) -findMatch (RepP: RepP: RepP: RepP: RepP: RepP: _) = (SLIT("pppppp"), 6) -findMatch (RepP: RepP: RepP: RepP: RepP: _) = (SLIT("ppppp"), 5) -findMatch (RepP: RepP: RepP: RepP: _) = (SLIT("pppp"), 4) -findMatch (RepP: RepP: RepP: _) = (SLIT("ppp"), 3) -findMatch (RepP: RepP: RepV: _) = (SLIT("ppv"), 3) -findMatch (RepP: RepP: _) = (SLIT("pp"), 2) -findMatch (RepP: RepV: _) = (SLIT("pv"), 2) -findMatch (RepP: _) = (SLIT("p"), 1) -findMatch (RepV: _) = (SLIT("v"), 1) -findMatch (RepN: _) = (SLIT("n"), 1) -findMatch (RepF: _) = (SLIT("f"), 1) -findMatch (RepD: _) = (SLIT("d"), 1) -findMatch (RepL: _) = (SLIT("l"), 1) -findMatch _ = panic "CgStackery.findMatch" - -#ifdef DEBUG -primRepChar p | isFollowableRep p = 'p' -primRepChar VoidRep = 'v' -primRepChar FloatRep = 'f' -primRepChar DoubleRep = 'd' -primRepChar p | getPrimRepSize p == 1 = 'n' -primRepChar p | is64BitRep p = 'l' - -traceSlowCall amodes and_then - = trace ("call: " ++ map primRepChar (map getAmodeRep amodes)) and_then -#endif + = do { rSp <- getRealSp + ; let (last_Sp_offset, offsets) = mkVirtStkOffsets tail_Sp things + abs_cs = [ CmmStore (cmmRegOffW spReg (spRel rSp offset)) amode + | (amode, offset) <- offsets + ] + ; returnFC (last_Sp_offset, toOL abs_cs) } \end{code} %************************************************************************ @@ -169,108 +156,150 @@ traceSlowCall amodes and_then Allocate a virtual offset for something. \begin{code} -allocPrimStack :: Int -> FCode VirtualSpOffset -allocPrimStack size = do - ((virt_sp, frame, free_stk, real_sp, hw_sp),h_usage) <- getUsage - let push_virt_sp = virt_sp + size - let (chosen_slot, new_stk_usage) = - case find_block free_stk of - Nothing -> (push_virt_sp, - (push_virt_sp, frame, free_stk, real_sp, - hw_sp `max` push_virt_sp)) +allocPrimStack :: CgRep -> FCode VirtualSpOffset +allocPrimStack rep + = do { stk_usg <- getStkUsage + ; let free_stk = freeStk stk_usg + ; case find_block free_stk of + Nothing -> do + { let push_virt_sp = virtSp stk_usg + size + ; setStkUsage (stk_usg { virtSp = push_virt_sp, + hwSp = hwSp stk_usg `max` push_virt_sp }) -- Adjust high water mark - Just slot -> (slot, - (virt_sp, frame, - delete_block free_stk slot, - real_sp, hw_sp)) - setUsage (new_stk_usage, h_usage) - return chosen_slot - - where - -- find_block looks for a contiguous chunk of free slots - find_block :: [(VirtualSpOffset,Slot)] -> Maybe VirtualSpOffset - find_block [] = Nothing - find_block ((off,free):slots) - | take size ((off,free):slots) == - zip [off..top_slot] (repeat Free) = Just top_slot - | otherwise = find_block slots - -- The stack grows downwards, with increasing virtual offsets. - -- Therefore, the address of a multi-word object is the *highest* - -- virtual offset it occupies (top_slot below). - where top_slot = off+size-1 - - delete_block free_stk slot = [ (s,f) | (s,f) <- free_stk, - (s<=slot-size) || (s>slot) ] - -- Retain slots which are not in the range - -- slot-size+1..slot + ; return push_virt_sp } + Just slot -> do + { setStkUsage (stk_usg { freeStk = delete_block free_stk slot }) + ; return slot } + } + where + size :: WordOff + size = cgRepSizeW rep + + -- Find_block looks for a contiguous chunk of free slots + -- returning the offset of its topmost word + find_block :: [VirtualSpOffset] -> Maybe VirtualSpOffset + find_block [] = Nothing + find_block (slot:slots) + | take size (slot:slots) == [slot..top_slot] + = Just top_slot + | otherwise + = find_block slots + where -- The stack grows downwards, with increasing virtual offsets. + -- Therefore, the address of a multi-word object is the *highest* + -- virtual offset it occupies (top_slot below). + top_slot = slot+size-1 + + delete_block free_stk slot = [ s | s <- free_stk, + (s<=slot-size) || (s>slot) ] + -- Retain slots which are not in the range + -- slot-size+1..slot \end{code} Allocate a chunk ON TOP OF the stack. -ToDo: should really register this memory as NonPointer stuff in the -free list. - \begin{code} -allocStackTop :: Int -> FCode VirtualSpOffset -allocStackTop size = do - ((virt_sp, frame, free_stk, real_sp, hw_sp), h_usage) <- getUsage - let push_virt_sp = virt_sp + size - let new_stk_usage = (push_virt_sp, frame, free_stk, real_sp, - hw_sp `max` push_virt_sp) - setUsage (new_stk_usage, h_usage) - return push_virt_sp +allocStackTop :: WordOff -> FCode VirtualSpOffset +allocStackTop size + = do { stk_usg <- getStkUsage + ; let push_virt_sp = virtSp stk_usg + size + ; setStkUsage (stk_usg { virtSp = push_virt_sp, + hwSp = hwSp stk_usg `max` push_virt_sp }) + ; return push_virt_sp } \end{code} Pop some words from the current top of stack. This is used for de-allocating the return address in a case alternative. \begin{code} -deAllocStackTop :: Int -> FCode VirtualSpOffset -deAllocStackTop size = do - ((virt_sp, frame, free_stk, real_sp, hw_sp), h_usage) <- getUsage - let pop_virt_sp = virt_sp - size - let new_stk_usage = (pop_virt_sp, frame, free_stk, real_sp, hw_sp) - setUsage (new_stk_usage, h_usage) - return pop_virt_sp +deAllocStackTop :: WordOff -> FCode VirtualSpOffset +deAllocStackTop size + = do { stk_usg <- getStkUsage + ; let pop_virt_sp = virtSp stk_usg - size + ; setStkUsage (stk_usg { virtSp = pop_virt_sp }) + ; return pop_virt_sp } \end{code} \begin{code} adjustStackHW :: VirtualSpOffset -> Code -adjustStackHW offset = do - ((vSp,fTop,fSp,realSp,hwSp), h_usage) <- getUsage - setUsage ((vSp, fTop, fSp, realSp, max offset hwSp), h_usage) +adjustStackHW offset + = do { stk_usg <- getStkUsage + ; setStkUsage (stk_usg { hwSp = hwSp stk_usg `max` offset }) } \end{code} A knot-tying beast. \begin{code} getFinalStackHW :: (VirtualSpOffset -> Code) -> Code -getFinalStackHW fcode = do - fixC (\hwSp -> do - fcode hwSp - ((_,_,_,_, hwSp),_) <- getUsage - return hwSp) - return () +getFinalStackHW fcode + = do { fixC (\hw_sp -> do + { fcode hw_sp + ; stk_usg <- getStkUsage + ; return (hwSp stk_usg) }) + ; return () } \end{code} \begin{code} setStackFrame :: VirtualSpOffset -> Code -setStackFrame offset = do - ((vSp,_,fSp,realSp,hwSp), h_usage) <- getUsage - setUsage ((vSp, offset, fSp, realSp, hwSp), h_usage) +setStackFrame offset + = do { stk_usg <- getStkUsage + ; setStkUsage (stk_usg { frameSp = offset }) } getStackFrame :: FCode VirtualSpOffset -getStackFrame = do - ((vSp,frame,fSp,realSp,hwSp), h_usage) <- getUsage - return frame +getStackFrame + = do { stk_usg <- getStkUsage + ; return (frameSp stk_usg) } \end{code} + +%******************************************************** +%* * +%* Setting up update frames * +%* * +%******************************************************** + +@pushUpdateFrame@ $updatee$ pushes a general update frame which +points to $updatee$ as the thing to be updated. It is only used +when a thunk has just been entered, so the (real) stack pointers +are guaranteed to be nicely aligned with the top of stack. +@pushUpdateFrame@ adjusts the virtual and tail stack pointers +to reflect the frame pushed. + \begin{code} -updateFrameSize | opt_SccProfilingOn = pROF_UF_SIZE - | opt_GranMacros = trace ("updateFrameSize = " ++ (show gRAN_UF_SIZE))gRAN_UF_SIZE - | otherwise = uF_SIZE +pushUpdateFrame :: CmmExpr -> Code -> Code + +pushUpdateFrame updatee code + = do { +#ifdef DEBUG + EndOfBlockInfo _ sequel <- getEndOfBlockInfo ; + ASSERT(case sequel of { OnStack -> True; _ -> False}) +#endif + + allocStackTop (fixedHdrSize + + sIZEOF_StgUpdateFrame_NoHdr `quot` wORD_SIZE) + ; vsp <- getVirtSp + ; setStackFrame vsp + ; frame_addr <- getSpRelOffset vsp + -- The location of the lowest-address + -- word of the update frame itself + + ; setEndOfBlockInfo (EndOfBlockInfo vsp UpdateCode) $ + do { emitPushUpdateFrame frame_addr updatee + ; code } + } + +emitPushUpdateFrame :: CmmExpr -> CmmExpr -> Code +emitPushUpdateFrame frame_addr updatee = do + stmtsC [ -- Set the info word + CmmStore frame_addr (mkLblExpr mkUpdInfoLabel) + , -- And the updatee + CmmStore (cmmOffsetB frame_addr off_updatee) updatee ] + initUpdFrameProf frame_addr + +off_updatee :: ByteOff +off_updatee = fixedHdrSize*wORD_SIZE + oFFSET_StgUpdateFrame_updatee \end{code} + %************************************************************************ %* * \subsection[CgStackery-free]{Free stack slots} @@ -280,50 +309,31 @@ updateFrameSize | opt_SccProfilingOn = pROF_UF_SIZE Explicitly free some stack space. \begin{code} -addFreeStackSlots :: [VirtualSpOffset] -> Slot -> Code -addFreeStackSlots extra_free slot = do - ((vsp, frame,free, real, hw),heap_usage) <- getUsage - let all_free = addFreeSlots free (zip (sortLt (<) extra_free) (repeat slot)) - let (new_vsp, new_free) = trim vsp all_free - let new_usage = ((new_vsp, frame, new_free, real, hw), heap_usage) - setUsage new_usage - freeStackSlots :: [VirtualSpOffset] -> Code -freeStackSlots slots = addFreeStackSlots slots Free - -dataStackSlots :: [VirtualSpOffset] -> Code -dataStackSlots slots = addFreeStackSlots slots NonPointer - -addFreeSlots :: [(Int,Slot)] -> [(Int,Slot)] -> [(Int,Slot)] +freeStackSlots extra_free + = do { stk_usg <- getStkUsage + ; let all_free = addFreeSlots (freeStk stk_usg) (sortLt (<) extra_free) + ; let (new_vsp, new_free) = trim (virtSp stk_usg) all_free + ; setStkUsage (stk_usg { virtSp = new_vsp, freeStk = new_free }) } + +addFreeSlots :: [VirtualSpOffset] -> [VirtualSpOffset] -> [VirtualSpOffset] +-- Merge the two, assuming both are in increasing order addFreeSlots cs [] = cs addFreeSlots [] ns = ns -addFreeSlots ((c,s):cs) ((n,s'):ns) - = if c < n then - (c,s) : addFreeSlots cs ((n,s'):ns) - else if c > n then - (n,s') : addFreeSlots ((c,s):cs) ns - else if s /= s' then -- c == n - (c,s') : addFreeSlots cs ns - else - panic ("addFreeSlots: equal slots: " ++ show (c:map fst cs) - ++ show (n:map fst ns)) - -trim :: Int{-offset-} -> [(Int,Slot)] -> (Int{-offset-}, [(Int,Slot)]) -trim current_sp free_slots - = try current_sp free_slots - where - try csp [] = (csp,[]) - - try csp (slot@(off,state):slots) = - if state == Free && null slots' then - if csp' < off then - (csp', []) - else if csp' == off then - (csp'-1, []) - else - (csp',[slot]) - else - (csp', slot:slots') - where - (csp',slots') = try csp slots +addFreeSlots (c:cs) (n:ns) + | c < n = c : addFreeSlots cs (n:ns) + | otherwise = n : addFreeSlots (c:cs) ns + +trim :: VirtualSpOffset -> [VirtualSpOffset] -> (VirtualSpOffset, [VirtualSpOffset]) +-- Try to trim back the virtual stack pointer, where there is a +-- continuous bunch of free slots at the end of the free list +trim vsp [] = (vsp, []) +trim vsp (slot:slots) + = case trim vsp slots of + (vsp', []) + | vsp' < slot -> pprTrace "trim: strange" (ppr vsp <+> ppr (slot:slots)) + (vsp', []) + | vsp' == slot -> (vsp'-1, []) + | otherwise -> (vsp', [slot]) + (vsp', slots') -> (vsp', slot:slots') \end{code} diff --git a/ghc/compiler/codeGen/CgTailCall.lhs b/ghc/compiler/codeGen/CgTailCall.lhs index 9d5118a77d..982891b2f7 100644 --- a/ghc/compiler/codeGen/CgTailCall.lhs +++ b/ghc/compiler/codeGen/CgTailCall.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgTailCall.lhs,v 1.38 2003/06/02 13:27:34 simonpj Exp $ +% $Id: CgTailCall.lhs,v 1.39 2004/08/13 13:06:13 simonmar Exp $ % %******************************************************** %* * @@ -13,9 +13,9 @@ module CgTailCall ( cgTailCall, performTailCall, performReturn, performPrimReturn, - mkStaticAlgReturnCode, mkDynamicAlgReturnCode, + emitKnownConReturnCode, emitAlgReturnCode, returnUnboxedTuple, ccallReturnUnboxedTuple, - mkPrimReturnCode, + pushUnboxedTuple, tailCallPrimOp, pushReturnAddress @@ -24,31 +24,31 @@ module CgTailCall ( #include "HsVersions.h" import CgMonad -import CgBindery ( getArgAmodes, getCAddrMode, getCAddrModeAndInfo ) -import CgRetConv -import CgStackery -import CgUsages ( getSpRelOffset, adjustSpAndHp ) +import CgBindery ( getArgAmodes, getCgIdInfo, CgIdInfo, maybeLetNoEscape, + idInfoToAmode, cgIdInfoId, cgIdInfoLF, + cgIdInfoArgRep ) +import CgInfoTbls ( entryCode, emitDirectReturnInstr, dataConTagZ, + emitVectoredReturnInstr, closureInfoPtr ) +import CgCallConv +import CgStackery ( setRealSp, mkStkAmodes, adjustStackHW, + getSpRelOffset ) +import CgHeapery ( setRealHp, getHpRelOffset ) +import CgUtils ( emitSimultaneously ) +import CgTicky import ClosureInfo - -import AbsCUtils ( mkAbstractCs, getAmodeRep ) -import AbsCSyn -import CLabel ( mkRtsPrimOpLabel, mkSeqInfoLabel ) - -import Id ( Id, idType, idName ) -import DataCon ( DataCon, dataConTyCon, dataConTag, fIRST_TAG ) -import PrimRep ( PrimRep(..) ) -import StgSyn ( StgArg ) +import SMRep ( CgRep, isVoidArg, separateByPtrFollowness ) +import Cmm +import CmmUtils +import CLabel ( CLabel, mkRtsPrimOpLabel, mkSeqInfoLabel ) import Type ( isUnLiftedType ) -import Name ( Name ) +import Id ( Id, idName, idUnique, idType ) +import DataCon ( DataCon, dataConTyCon ) +import StgSyn ( StgArg ) import TyCon ( TyCon ) import PrimOp ( PrimOp ) -import Util ( zipWithEqual, splitAtList ) -import ListSetOps ( assocMaybe ) -import PrimRep ( isFollowableRep ) import Outputable -import Panic ( panic, assertPanic ) -import List ( partition ) +import Monad ( when ) ----------------------------------------------------------------------------- -- Tail Calls @@ -75,339 +75,205 @@ cgTailCall :: Id -> [StgArg] -> Code -- Treat unboxed locals exactly like literals (above) except use the addr -- mode for the local instead of (CLit lit) in the assignment. --- Case for unboxed returns first: -cgTailCall fun [] - | isUnLiftedType (idType fun) - = getCAddrMode fun `thenFC` \ amode -> - performPrimReturn (ppr fun) amode - --- The general case (@fun@ is boxed): cgTailCall fun args - = getCAddrModeAndInfo fun `thenFC` \ (fun', fun_amode, lf_info) -> - getArgAmodes args `thenFC` \ arg_amodes -> - performTailCall fun' fun_amode lf_info arg_amodes AbsCNop - + = do { fun_info <- getCgIdInfo fun + + ; if isUnLiftedType (idType fun) + then -- Primitive return + ASSERT( null args ) + do { fun_amode <- idInfoToAmode fun_info + ; performPrimReturn (cgIdInfoArgRep fun_info) fun_amode } + + else -- Normal case, fun is boxed + do { arg_amodes <- getArgAmodes args + ; performTailCall fun_info arg_amodes noStmts } + } + -- ----------------------------------------------------------------------------- -- The guts of a tail-call performTailCall - :: Id -- function - -> CAddrMode -- function amode - -> LambdaFormInfo - -> [CAddrMode] - -> AbstractC -- Pending simultaneous assignments - -- *** GUARANTEED to contain only stack assignments. + :: CgIdInfo -- The function + -> [(CgRep,CmmExpr)] -- Args + -> CmmStmts -- Pending simultaneous assignments + -- *** GUARANTEED to contain only stack assignments. -> Code -performTailCall fun fun_amode lf_info arg_amodes pending_assts = - nodeMustPointToIt lf_info `thenFC` \ node_points -> - let - -- assign to node if necessary - node_asst - | node_points = CAssign (CReg node) fun_amode - | otherwise = AbsCNop - in - - getEndOfBlockInfo `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) -> - - let - -- set up for a let-no-escape if necessary - join_sp = case fun_amode of - CJoinPoint sp -> sp - other -> args_sp - in - - -- decide how to code the tail-call: which registers assignments to make, - -- what args to push on the stack, and how to make the jump - constructTailCall (idName fun) lf_info arg_amodes join_sp - node_points fun_amode sequel - `thenFC` \ (final_sp, arg_assts, jump_code) -> - - let sim_assts = mkAbstractCs [node_asst, - pending_assts, - arg_assts] - - is_lne = case fun_amode of { CJoinPoint _ -> True; _ -> False } - in - - doFinalJump final_sp sim_assts is_lne (const jump_code) - - --- Figure out how to do a particular tail-call. - -constructTailCall - :: Name - -> LambdaFormInfo - -> [CAddrMode] - -> VirtualSpOffset -- Sp at which to make the call - -> Bool -- node points to the fun closure? - -> CAddrMode -- addressing mode of the function - -> Sequel -- the sequel, in case we need it - -> FCode ( - VirtualSpOffset, -- Sp after pushing the args - AbstractC, -- assignments - Code -- code to do the jump - ) - -constructTailCall name lf_info arg_amodes sp node_points fun_amode sequel = - - getEntryConvention name lf_info (map getAmodeRep arg_amodes) - `thenFC` \ entry_conv -> - - case entry_conv of - EnterIt -> returnFC (sp, AbsCNop, code) - where code = profCtrC FSLIT("TICK_ENT_VIA_NODE") [] `thenC` - absC (CJump (CMacroExpr CodePtrRep ENTRY_CODE - [CVal (nodeRel 0) DataPtrRep])) - - -- A function, but we have zero arguments. It is already in WHNF, - -- so we can just return it. - ReturnIt -> returnFC (sp, asst, code) - where -- if node doesn't already point to the closure, we have to - -- load it up. - asst | node_points = AbsCNop - | otherwise = CAssign (CReg node) fun_amode - - code = sequelToAmode sequel `thenFC` \ dest_amode -> - absC (CReturn dest_amode DirectReturn) - - JumpToIt lbl -> returnFC (sp, AbsCNop, code) - where code = absC (CJump (CLbl lbl CodePtrRep)) - - -- a slow function call via the RTS apply routines - SlowCall -> - let (apply_fn, new_amodes) = constructSlowCall arg_amodes - - -- if node doesn't already point to the closure, - -- we have to load it up. - node_asst | node_points = AbsCNop - | otherwise = CAssign (CReg node) fun_amode - in - - -- Fill in all the arguments on the stack - mkStkAmodes sp new_amodes `thenFC` - \ (final_sp, stk_assts) -> - - returnFC - (final_sp + 1, -- add one, because the stg_ap functions - -- expect there to be a free slot on the stk - mkAbstractCs [node_asst, stk_assts], - absC (CJump apply_fn) - ) - - -- A direct function call (possibly with some left-over arguments) - DirectEntry lbl arity regs - - -- A let-no-escape is slightly different, because we +performTailCall fun_info arg_amodes pending_assts + | Just join_sp <- maybeLetNoEscape fun_info + = -- A let-no-escape is slightly different, because we -- arrange the stack arguments into pointers and non-pointers -- to make the heap check easier. The tail-call sequence -- is very similar to returning an unboxed tuple, so we -- share some code. - | is_let_no_escape -> - pushUnboxedTuple sp arg_amodes `thenFC` \ (final_sp, assts) -> - returnFC (final_sp, assts, absC (CJump (CLbl lbl CodePtrRep))) - - - -- A normal fast call - | otherwise -> - let - -- first chunk of args go in registers - (reg_arg_amodes, stk_arg_amodes) = - splitAtList regs arg_amodes - - -- the rest of this function's args go straight on the stack - (stk_args, extra_stk_args) = - splitAt (arity - length regs) stk_arg_amodes - - -- any "extra" arguments are placed in frames on the - -- stack after the other arguments. - slow_stk_args = slowArgs extra_stk_args - - reg_assts - = mkAbstractCs (zipWithEqual "assign_to_reg2" - assign_to_reg regs reg_arg_amodes) + do { (final_sp, arg_assts) <- pushUnboxedTuple join_sp arg_amodes + ; emitSimultaneously (pending_assts `plusStmts` arg_assts) + ; let lbl = enterReturnPtLabel (idUnique (cgIdInfoId fun_info)) + ; doFinalJump final_sp True {- Is LNE -} (jumpToLbl lbl) } + + | otherwise + = do { fun_amode <- idInfoToAmode fun_info + ; let node_asst = oneStmt (CmmAssign nodeReg fun_amode) + opt_node_asst | nodeMustPointToIt lf_info = node_asst + | otherwise = noStmts + ; EndOfBlockInfo sp _ <- getEndOfBlockInfo + + ; case (getCallMethod fun_name lf_info (length arg_amodes)) of + + -- Node must always point to things we enter + EnterIt -> do + { emitSimultaneously (node_asst `plusStmts` pending_assts) + ; let target = entryCode (closureInfoPtr (CmmReg nodeReg)) + ; doFinalJump sp False (stmtC (CmmJump target [])) } + + -- A function, but we have zero arguments. It is already in WHNF, + -- so we can just return it. + -- As with any return, Node must point to it. + ReturnIt -> do + { emitSimultaneously (node_asst `plusStmts` pending_assts) + ; doFinalJump sp False emitDirectReturnInstr } + + -- A real constructor. Don't bother entering it, + -- just do the right sort of return instead. + -- As with any return, Node must point to it. + ReturnCon con -> do + { emitSimultaneously (node_asst `plusStmts` pending_assts) + ; doFinalJump sp False (emitKnownConReturnCode con) } + + JumpToIt lbl -> do + { emitSimultaneously (opt_node_asst `plusStmts` pending_assts) + ; doFinalJump sp False (jumpToLbl lbl) } + + -- A slow function call via the RTS apply routines + -- Node must definitely point to the thing + SlowCall -> do + { let (apply_lbl, new_amodes) = constructSlowCall arg_amodes - in - mkStkAmodes sp (stk_args ++ slow_stk_args) `thenFC` - \ (final_sp, stk_assts) -> + -- Fill in all the arguments on the stack + ; (final_sp,stk_assts) <- mkStkAmodes sp new_amodes + + ; emitSimultaneously (node_asst `plusStmts` stk_assts + `plusStmts` pending_assts) + + ; when (not (null arg_amodes)) $ do + { if (isKnownFun lf_info) + then tickyKnownCallTooFewArgs + else tickyUnknownCall + ; tickySlowCallPat (map fst arg_amodes) + } + + ; doFinalJump (final_sp + 1) + -- Add one, because the stg_ap functions + -- expect there to be a free slot on the stk + False (jumpToLbl apply_lbl) + } + + -- A direct function call (possibly with some left-over arguments) + DirectEntry lbl arity -> do + { let + -- The args beyond the arity go straight on the stack + (arity_args, extra_stk_args) = splitAt arity arg_amodes + + -- First chunk of args go in registers + (reg_arg_amodes, stk_args) = assignCallRegs arity_args + + -- Any "extra" arguments are placed in frames on the + -- stack after the other arguments. + slow_stk_args = slowArgs extra_stk_args + + reg_assts = assignToRegs reg_arg_amodes + + ; if null slow_stk_args + then tickyKnownCallExact + else do tickyKnownCallExtraArgs + tickySlowCallPat (map fst extra_stk_args) + + ; (final_sp, stk_assts) <- mkStkAmodes sp + (stk_args ++ slow_stk_args) + + ; emitSimultaneously (opt_node_asst `plusStmts` + reg_assts `plusStmts` + stk_assts `plusStmts` + pending_assts) + + ; doFinalJump final_sp False (jumpToLbl lbl) } + } + where + fun_name = idName (cgIdInfoId fun_info) + lf_info = cgIdInfoLF fun_info - returnFC - (final_sp, - mkAbstractCs [reg_assts, stk_assts], - absC (CJump (CLbl lbl CodePtrRep)) - ) - where is_let_no_escape = case fun_amode of - CJoinPoint _ -> True - _ -> False -- ----------------------------------------------------------------------------- -- The final clean-up before we do a jump at the end of a basic block. -- This code is shared by tail-calls and returns. -doFinalJump :: VirtualSpOffset -> AbstractC -> Bool -> (Sequel -> Code) -> Code -doFinalJump final_sp sim_assts is_let_no_escape jump_code = - - -- adjust the high-water mark if necessary - adjustStackHW final_sp `thenC` +doFinalJump :: VirtualSpOffset -> Bool -> Code -> Code +doFinalJump final_sp is_let_no_escape jump_code + = do { -- Adjust the high-water mark if necessary + adjustStackHW final_sp - -- Do the simultaneous assignments, - absC (CSimultaneous sim_assts) `thenC` - - -- push a return address if necessary (after the assignments + -- Push a return address if necessary (after the assignments -- above, in case we clobber a live stack location) -- -- DONT push the return address when we're about to jump to a -- let-no-escape: the final tail call in the let-no-escape -- will do this. - getEndOfBlockInfo `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) -> - (if is_let_no_escape then nopC - else pushReturnAddress eob) `thenC` + ; eob <- getEndOfBlockInfo + ; whenC (not is_let_no_escape) (pushReturnAddress eob) - -- Final adjustment of Sp/Hp - adjustSpAndHp final_sp `thenC` + -- Final adjustment of Sp/Hp + ; adjustSpAndHp final_sp - -- and do the jump - jump_code sequel + -- and do the jump + ; jump_code } -- ----------------------------------------------------------------------------- -- A general return (just a special case of doFinalJump, above) -performReturn :: AbstractC -- Simultaneous assignments to perform - -> (Sequel -> Code) -- The code to execute to actually do - -- the return, given an addressing mode - -- for the return address +performReturn :: Code -- The code to execute to actually do the return -> Code -performReturn sim_assts finish_code - = getEndOfBlockInfo `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) -> - doFinalJump args_sp sim_assts False{-not a LNE-} finish_code +performReturn finish_code + = do { EndOfBlockInfo args_sp sequel <- getEndOfBlockInfo + ; doFinalJump args_sp False{-not a LNE-} finish_code } -- ----------------------------------------------------------------------------- -- Primitive Returns - -- Just load the return value into the right register, and return. -performPrimReturn :: SDoc -- Just for debugging (sigh) - -> CAddrMode -- The thing to return +performPrimReturn :: CgRep -> CmmExpr -- The thing to return -> Code - -performPrimReturn doc amode - = let - kind = getAmodeRep amode - ret_reg = dataReturnConvPrim kind - - assign_possibly = case kind of - VoidRep -> AbsCNop - kind -> (CAssign (CReg ret_reg) amode) - in - performReturn assign_possibly (mkPrimReturnCode doc) - -mkPrimReturnCode :: SDoc -- Debugging only - -> Sequel - -> Code -mkPrimReturnCode doc UpdateCode = pprPanic "mkPrimReturnCode: Upd" doc -mkPrimReturnCode doc sequel = sequelToAmode sequel `thenFC` \ dest_amode -> - absC (CReturn dest_amode DirectReturn) - -- Direct, no vectoring +performPrimReturn rep amode + = do { whenC (not (isVoidArg rep)) + (stmtC (CmmAssign ret_reg amode)) + ; performReturn emitDirectReturnInstr } + where + ret_reg = dataReturnConvPrim rep -- ----------------------------------------------------------------------------- -- Algebraic constructor returns -- Constructor is built on the heap; Node is set. --- All that remains is --- (a) to set TagReg, if necessary --- (c) to do the right sort of jump. - -mkStaticAlgReturnCode :: DataCon -- The constructor - -> Sequel -- where to return to - -> Code - -mkStaticAlgReturnCode con sequel - = -- Generate profiling code if necessary - (case return_convention of - VectoredReturn sz -> profCtrC FSLIT("TICK_VEC_RETURN") [mkIntCLit sz] - other -> nopC - ) `thenC` - - -- Set tag if necessary - -- This is done by a macro, because if we are short of registers - -- we don't set TagReg; instead the continuation gets the tag - -- by indexing off the info ptr - (case return_convention of - - UnvectoredReturn no_of_constrs - | no_of_constrs > 1 - -> absC (CMacroStmt SET_TAG [mkIntCLit zero_indexed_tag]) - - other -> nopC - ) `thenC` - - -- Generate the right jump or return - (case sequel of - CaseAlts _ (Just (alts, _)) False -> -- Ho! We know the constructor so - -- we can go right to the alternative - - case assocMaybe alts tag of - Just (alt_absC, join_lbl) -> - absC (CJump (CLbl join_lbl CodePtrRep)) - Nothing -> panic "mkStaticAlgReturnCode: default" - -- The Nothing case should never happen; - -- it's the subject of a wad of special-case - -- code in cgReturnCon - - other -> -- OnStack, or (CaseAlts ret_amode Nothing), - -- or UpdateCode. - sequelToAmode sequel `thenFC` \ ret_amode -> - absC (CReturn ret_amode return_info) - ) +-- All that remains is to do the right sort of jump. - where - tag = dataConTag con - tycon = dataConTyCon con - return_convention = ctrlReturnConvAlg tycon - zero_indexed_tag = tag - fIRST_TAG -- Adjust tag to be zero-indexed - -- cf AbsCUtils.mkAlgAltsCSwitch - - return_info = - case return_convention of - UnvectoredReturn _ -> DirectReturn - VectoredReturn _ -> StaticVectoredReturn zero_indexed_tag - - --- ----------------------------------------------------------------------------- --- Returning an enumerated type from a PrimOp +emitKnownConReturnCode :: DataCon -> Code +emitKnownConReturnCode con + = emitAlgReturnCode (dataConTyCon con) + (CmmLit (mkIntCLit (dataConTagZ con))) + -- emitAlgReturnCode requires zero-indexed tag --- This function is used by PrimOps that return enumerated types (i.e. +emitAlgReturnCode :: TyCon -> CmmExpr -> Code +-- emitAlgReturnCode is used both by emitKnownConReturnCode, +-- and by by PrimOps that return enumerated types (i.e. -- all the comparison operators). - -mkDynamicAlgReturnCode :: TyCon -> CAddrMode -> Sequel -> Code - -mkDynamicAlgReturnCode tycon dyn_tag sequel - = case ctrlReturnConvAlg tycon of - VectoredReturn sz -> - - profCtrC FSLIT("TICK_VEC_RETURN") [mkIntCLit sz] `thenC` - sequelToAmode sequel `thenFC` \ ret_addr -> - absC (CReturn ret_addr (DynamicVectoredReturn dyn_tag)) - - UnvectoredReturn no_of_constrs -> - - -- Set tag if necessary - -- This is done by a macro, because if we are short of registers - -- we don't set TagReg; instead the continuation gets the tag - -- by indexing off the info ptr - (if no_of_constrs > 1 then - absC (CMacroStmt SET_TAG [dyn_tag]) - else - nopC - ) `thenC` - - - sequelToAmode sequel `thenFC` \ ret_addr -> - -- Generate the right jump or return - absC (CReturn ret_addr DirectReturn) +emitAlgReturnCode tycon tag + = do { case ctrlReturnConvAlg tycon of + VectoredReturn fam_sz -> do { tickyVectoredReturn fam_sz + ; emitVectoredReturnInstr tag } + UnvectoredReturn _ -> emitDirectReturnInstr + } -- --------------------------------------------------------------------------- @@ -424,59 +290,37 @@ mkDynamicAlgReturnCode tycon dyn_tag sequel -- let-no-escape functions, because they also can't be partially -- applied. -returnUnboxedTuple :: [CAddrMode] -> Code -returnUnboxedTuple amodes = - getEndOfBlockInfo `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) -> - - profCtrC FSLIT("TICK_RET_UNBOXED_TUP") [mkIntCLit (length amodes)] `thenC` - - pushUnboxedTuple args_sp amodes `thenFC` \ (final_sp, assts) -> - doFinalJump final_sp assts False{-not a LNE-} mkUnboxedTupleReturnCode - - -pushUnboxedTuple - :: VirtualSpOffset -- Sp at which to start pushing - -> [CAddrMode] -- amodes of the components - -> FCode (VirtualSpOffset, -- final Sp - AbstractC) -- assignments (regs+stack) - -pushUnboxedTuple sp amodes = - let - (arg_regs, _leftovers) = assignRegs [] (map getAmodeRep amodes) - - (reg_arg_amodes, stk_arg_amodes) = splitAtList arg_regs amodes - - -- separate the rest of the args into pointers and non-pointers - ( ptr_args, nptr_args ) = - partition (isFollowableRep . getAmodeRep) stk_arg_amodes - - reg_arg_assts - = mkAbstractCs (zipWithEqual "assign_to_reg2" - assign_to_reg arg_regs reg_arg_amodes) - in - - -- push ptrs, then nonptrs, on the stack - mkStkAmodes sp ptr_args `thenFC` \ (ptr_sp, ptr_assts) -> - mkStkAmodes ptr_sp nptr_args `thenFC` \ (final_sp, nptr_assts) -> +returnUnboxedTuple :: [(CgRep, CmmExpr)] -> Code +returnUnboxedTuple amodes + = do { eob@(EndOfBlockInfo args_sp sequel) <- getEndOfBlockInfo + ; tickyUnboxedTupleReturn (length amodes) + ; (final_sp, assts) <- pushUnboxedTuple args_sp amodes + ; emitSimultaneously assts + ; doFinalJump final_sp False{-not a LNE-} emitDirectReturnInstr } + +pushUnboxedTuple :: VirtualSpOffset -- Sp at which to start pushing + -> [(CgRep, CmmExpr)] -- amodes of the components + -> FCode (VirtualSpOffset, -- final Sp + CmmStmts) -- assignments (regs+stack) + +pushUnboxedTuple sp [] + = return (sp, noStmts) +pushUnboxedTuple sp amodes + = do { let (reg_arg_amodes, stk_arg_amodes) = assignReturnRegs amodes + + -- separate the rest of the args into pointers and non-pointers + (ptr_args, nptr_args) = separateByPtrFollowness stk_arg_amodes + reg_arg_assts = assignToRegs reg_arg_amodes + + -- push ptrs, then nonptrs, on the stack + ; (ptr_sp, ptr_assts) <- mkStkAmodes sp ptr_args + ; (final_sp, nptr_assts) <- mkStkAmodes ptr_sp nptr_args - returnFC (final_sp, - mkAbstractCs [reg_arg_assts, ptr_assts, nptr_assts]) + ; returnFC (final_sp, + reg_arg_assts `plusStmts` + ptr_assts `plusStmts` nptr_assts) } - -mkUnboxedTupleReturnCode :: Sequel -> Code -mkUnboxedTupleReturnCode sequel - = case sequel of - -- can't update with an unboxed tuple! - UpdateCode -> panic "mkUnboxedTupleReturnCode" - - CaseAlts _ (Just ([(_,(alt_absC,join_lbl))], _)) False -> - absC (CJump (CLbl join_lbl CodePtrRep)) - - other -> -- OnStack, or (CaseAlts ret_amode something) - sequelToAmode sequel `thenFC` \ ret_amode -> - absC (CReturn ret_amode DirectReturn) - -- ----------------------------------------------------------------------------- -- Returning unboxed tuples. This is mainly to support _ccall_GC_, where -- we want to do things in a slightly different order to normal: @@ -494,44 +338,35 @@ mkUnboxedTupleReturnCode sequel -- (in order to avoid pushing it again), so we end up doing a needless -- indirect jump (ToDo). -ccallReturnUnboxedTuple :: [CAddrMode] -> Code -> Code +ccallReturnUnboxedTuple :: [(CgRep, CmmExpr)] -> Code -> Code ccallReturnUnboxedTuple amodes before_jump - = getEndOfBlockInfo `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) -> - - -- push a return address if necessary - pushReturnAddress eob `thenC` - setEndOfBlockInfo (EndOfBlockInfo args_sp (OnStack args_sp)) ( - - -- Adjust Sp/Hp - adjustSpAndHp args_sp `thenC` + = do { eob@(EndOfBlockInfo args_sp _) <- getEndOfBlockInfo - before_jump `thenC` - - returnUnboxedTuple amodes - ) + -- Push a return address if necessary + ; pushReturnAddress eob + ; setEndOfBlockInfo (EndOfBlockInfo args_sp OnStack) + (do { adjustSpAndHp args_sp + ; before_jump + ; returnUnboxedTuple amodes }) + } -- ----------------------------------------------------------------------------- -- Calling an out-of-line primop tailCallPrimOp :: PrimOp -> [StgArg] -> Code -tailCallPrimOp op args = - -- we're going to perform a normal-looking tail call, - -- except that *all* the arguments will be in registers. - getArgAmodes args `thenFC` \ arg_amodes -> - let (arg_regs, leftovers) = assignAllRegs [] (map getAmodeRep arg_amodes) +tailCallPrimOp op args + = do { -- We're going to perform a normal-looking tail call, + -- except that *all* the arguments will be in registers. + -- Hence the ASSERT( null leftovers ) + arg_amodes <- getArgAmodes args + ; let (arg_regs, leftovers) = assignPrimOpCallRegs arg_amodes + jump_to_primop = jumpToLbl (mkRtsPrimOpLabel op) - reg_arg_assts - = mkAbstractCs (zipWithEqual "assign_to_reg2" - assign_to_reg arg_regs arg_amodes) + ; ASSERT(null leftovers) -- no stack-resident args + emitSimultaneously (assignToRegs arg_regs) - jump_to_primop = - absC (CJump (CLbl (mkRtsPrimOpLabel op) CodePtrRep)) - in - - ASSERT(null leftovers) -- no stack-resident args - - getEndOfBlockInfo `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) -> - doFinalJump args_sp reg_arg_assts False{-not a LNE-} (const jump_to_primop) + ; EndOfBlockInfo args_sp _ <- getEndOfBlockInfo + ; doFinalJump args_sp False{-not a LNE-} jump_to_primop } -- ----------------------------------------------------------------------------- -- Return Addresses @@ -551,23 +386,72 @@ tailCallPrimOp op args = pushReturnAddress :: EndOfBlockInfo -> Code -pushReturnAddress (EndOfBlockInfo args_sp sequel@(CaseAlts amode _ False)) = - getSpRelOffset args_sp `thenFC` \ sp_rel -> - absC (CAssign (CVal sp_rel RetRep) amode) +pushReturnAddress (EndOfBlockInfo args_sp sequel@(CaseAlts lbl _ _ False)) + = do { sp_rel <- getSpRelOffset args_sp + ; stmtC (CmmStore sp_rel (mkLblExpr lbl)) } -- For a polymorphic case, we have two return addresses to push: the case -- return, and stg_seq_frame_info which turns a possible vectored return -- into a direct one. -pushReturnAddress (EndOfBlockInfo args_sp sequel@(CaseAlts amode _ True)) = - getSpRelOffset (args_sp-1) `thenFC` \ sp_rel -> - absC (CAssign (CVal sp_rel RetRep) amode) `thenC` - getSpRelOffset args_sp `thenFC` \ sp_rel -> - absC (CAssign (CVal sp_rel RetRep) (CLbl mkSeqInfoLabel RetRep)) +pushReturnAddress (EndOfBlockInfo args_sp sequel@(CaseAlts lbl _ _ True)) + = do { sp_rel <- getSpRelOffset (args_sp-1) + ; stmtC (CmmStore sp_rel (mkLblExpr lbl)) + ; sp_rel <- getSpRelOffset args_sp + ; stmtC (CmmStore sp_rel (CmmLit (CmmLabel mkSeqInfoLabel))) } + pushReturnAddress _ = nopC -- ----------------------------------------------------------------------------- -- Misc. -assign_to_reg reg_id amode = CAssign (CReg reg_id) amode +jumpToLbl :: CLabel -> Code +-- Passes no argument to the destination procedure +jumpToLbl lbl = stmtC (CmmJump (CmmLit (CmmLabel lbl)) [{- No args -}]) +assignToRegs :: [(CmmExpr, GlobalReg)] -> CmmStmts +assignToRegs reg_args + = mkStmts [ CmmAssign (CmmGlobal reg_id) expr + | (expr, reg_id) <- reg_args ] +\end{code} + + +%************************************************************************ +%* * +\subsection[CgStackery-adjust]{Adjusting the stack pointers} +%* * +%************************************************************************ + +This function adjusts the stack and heap pointers just before a tail +call or return. The stack pointer is adjusted to its final position +(i.e. to point to the last argument for a tail call, or the activation +record for a return). The heap pointer may be moved backwards, in +cases where we overallocated at the beginning of the basic block (see +CgCase.lhs for discussion). + +These functions {\em do not} deal with high-water-mark adjustment. +That's done by functions which allocate stack space. + +\begin{code} +adjustSpAndHp :: VirtualSpOffset -- New offset for Arg stack ptr + -> Code +adjustSpAndHp newRealSp + = do { -- Adjust stack, if necessary. + -- NB: the conditional on the monad-carried realSp + -- is out of line (via codeOnly), to avoid a black hole + ; new_sp <- getSpRelOffset newRealSp + ; checkedAbsC (CmmAssign spReg new_sp) -- Will generate no code in the case + ; setRealSp newRealSp -- where realSp==newRealSp + + -- Adjust heap. The virtual heap pointer may be less than the real Hp + -- because the latter was advanced to deal with the worst-case branch + -- of the code, and we may be in a better-case branch. In that case, + -- move the real Hp *back* and retract some ticky allocation count. + ; hp_usg <- getHpUsage + ; let rHp = realHp hp_usg + vHp = virtHp hp_usg + ; new_hp <- getHpRelOffset vHp + ; checkedAbsC (CmmAssign hpReg new_hp) -- Generates nothing when vHp==rHp + ; tickyAllocHeap (vHp - rHp) -- ...ditto + ; setRealHp vHp + } \end{code} diff --git a/ghc/compiler/codeGen/CgTicky.hs b/ghc/compiler/codeGen/CgTicky.hs new file mode 100644 index 0000000000..19dbc43aac --- /dev/null +++ b/ghc/compiler/codeGen/CgTicky.hs @@ -0,0 +1,370 @@ +----------------------------------------------------------------------------- +-- +-- Code generation for ticky-ticky profiling +-- +-- (c) The University of Glasgow 2004 +-- +----------------------------------------------------------------------------- + +module CgTicky ( + emitTickyCounter, + + tickyDynAlloc, + tickyAllocHeap, + tickyAllocPrim, + tickyAllocThunk, + tickyAllocPAP, + + tickyPushUpdateFrame, + tickyUpdateFrameOmitted, + + tickyEnterDynCon, + tickyEnterStaticCon, + tickyEnterViaNode, + + tickyEnterFun, + tickyEnterThunk, + + tickyUpdateBhCaf, + tickyBlackHole, + tickyUnboxedTupleReturn, tickyVectoredReturn, + tickyReturnOldCon, tickyReturnNewCon, + + tickyKnownCallTooFewArgs, tickyKnownCallExact, tickyKnownCallExtraArgs, + tickyUnknownCall, tickySlowCallPat, + + staticTickyHdr, + ) where + +#include "HsVersions.h" +#include "../includes/DerivedConstants.h" + -- For REP_xxx constants, which are MachReps + +import ClosureInfo ( ClosureInfo, closureSize, slopSize, closureSMRep, + closureUpdReqd, closureName, isStaticClosure ) +import CgUtils +import CgMonad +import SMRep ( ClosureType(..), smRepClosureType, CgRep ) + +import Cmm +import MachOp +import CmmUtils ( zeroCLit, mkIntCLit, mkLblExpr, cmmIndexExpr ) +import CLabel ( CLabel, mkRtsDataLabel, mkRednCountsLabel ) + +import Name ( isInternalName ) +import Id ( Id, idType ) +import CmdLineOpts ( opt_DoTickyProfiling ) +import BasicTypes ( Arity ) +import FastString ( FastString, mkFastString, LitString ) +import Constants -- Lots of field offsets +import Outputable + +-- Turgid imports for showTypeCategory +import PrelNames +import TcType ( Type, isDictTy, tcSplitTyConApp_maybe, + tcSplitFunTy_maybe ) +import TyCon ( isPrimTyCon, isTupleTyCon, isEnumerationTyCon, + maybeTyConSingleCon ) +import Maybe + +----------------------------------------------------------------------------- +-- +-- Ticky-ticky profiling +-- +----------------------------------------------------------------------------- + +staticTickyHdr :: [CmmLit] +-- The ticky header words in a static closure +-- Was SET_STATIC_TICKY_HDR +staticTickyHdr + | not opt_DoTickyProfiling = [] + | otherwise = [zeroCLit] + +emitTickyCounter :: ClosureInfo -> [Id] -> Int -> Code +emitTickyCounter cl_info args on_stk + = ifTicky $ + do { mod_name <- moduleName + ; fun_descr_lit <- mkStringCLit (fun_descr mod_name) + ; arg_descr_lit <- mkStringCLit arg_descr + ; emitDataLits ticky_ctr_label -- Must match layout of StgEntCounter + [ CmmInt 0 I16, + CmmInt (fromIntegral (length args)) I16, -- Arity + CmmInt (fromIntegral on_stk) I16, -- Words passed on stack + CmmInt 0 I16, -- 2-byte gap + fun_descr_lit, + arg_descr_lit, + zeroCLit, -- Entry count + zeroCLit, -- Allocs + zeroCLit -- Link + ] } + where + name = closureName cl_info + ticky_ctr_label = mkRednCountsLabel name + arg_descr = map (showTypeCategory . idType) args + fun_descr mod_name = ppr_for_ticky_name mod_name name + +-- When printing the name of a thing in a ticky file, we want to +-- give the module name even for *local* things. We print +-- just "x (M)" rather that "M.x" to distinguish them from the global kind. +ppr_for_ticky_name mod_name name + | isInternalName name = showSDocDebug (ppr name <+> (parens (ppr mod_name))) + | otherwise = showSDocDebug (ppr name) + +-- ----------------------------------------------------------------------------- +-- Ticky stack frames + +tickyPushUpdateFrame = ifTicky $ bumpTickyCounter SLIT("UPDF_PUSHED_ctr") +tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter SLIT("UPDF_OMITTED_ctr") + +-- ----------------------------------------------------------------------------- +-- Ticky entries + +tickyEnterDynCon = ifTicky $ bumpTickyCounter SLIT("ENT_DYN_CON_ctr") +tickyEnterDynThunk = ifTicky $ bumpTickyCounter SLIT("ENT_DYN_THK_ctr") +tickyEnterStaticCon = ifTicky $ bumpTickyCounter SLIT("ENT_STATIC_CON_ctr") +tickyEnterStaticThunk = ifTicky $ bumpTickyCounter SLIT("ENT_STATIC_THK_ctr") +tickyEnterViaNode = ifTicky $ bumpTickyCounter SLIT("ENT_VIA_NODE_ctr") + +tickyEnterThunk :: ClosureInfo -> Code +tickyEnterThunk cl_info + | isStaticClosure cl_info = tickyEnterStaticThunk + | otherwise = tickyEnterDynThunk + +tickyBlackHole :: Bool{-updatable-} -> Code +tickyBlackHole updatable + = ifTicky (bumpTickyCounter ctr) + where + ctr | updatable = SLIT("UPD_BH_SINGLE_ENTRY_ctr") + | otherwise = SLIT("UPD_BH_UPDATABLE_ctr") + +tickyUpdateBhCaf cl_info + = ifTicky (bumpTickyCounter ctr) + where + ctr | closureUpdReqd cl_info = SLIT("UPD_CAF_BH_SINGLE_ENTRY_ctr") + | otherwise = SLIT("UPD_CAF_BH_UPDATABLE_ctr") + +tickyEnterFun :: ClosureInfo -> Code +tickyEnterFun cl_info + = ifTicky $ + do { bumpTickyCounter ctr + ; fun_ctr_lbl <- getTickyCtrLabel + ; registerTickyCtr fun_ctr_lbl + ; bumpTickyCounter' fun_ctr_lbl } + where + ctr | isStaticClosure cl_info = SLIT("TICK_ENT_STATIC_FUN_DIRECT") + | otherwise = SLIT("TICK_ENT_DYN_FUN_DIRECT") + +registerTickyCtr :: CLabel -> Code +-- Register a ticky counter +-- if ( ! f_ct.registeredp ) { +-- f_ct.link = ticky_entry_ctrs; /* hook this one onto the front of the list */ +-- ticky_entry_ctrs = & (f_ct); /* mark it as "registered" */ +-- f_ct.registeredp = 1 } +registerTickyCtr ctr_lbl + = emitIf test (stmtsC register_stmts) + where + test = CmmMachOp (MO_Not I16) + [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl + oFFSET_StgEntCounter_registeredp)) I16] + register_stmts + = [ CmmStore (CmmLit (cmmLabelOffB ctr_lbl oFFSET_StgEntCounter_link)) + (CmmLoad ticky_entry_ctrs wordRep) + , CmmStore ticky_entry_ctrs (mkLblExpr ctr_lbl) + , CmmStore (CmmLit (cmmLabelOffB ctr_lbl + oFFSET_StgEntCounter_registeredp)) + (CmmLit (mkIntCLit 1)) ] + ticky_entry_ctrs = mkLblExpr (mkRtsDataLabel SLIT("ticky_entry_ctrs")) + +tickyReturnOldCon, tickyReturnNewCon :: Arity -> Code +tickyReturnOldCon arity + = ifTicky $ do { bumpTickyCounter SLIT("RET_OLD_ctr") + ; bumpHistogram SLIT("RET_OLD_hst") arity } +tickyReturnNewCon arity + | not opt_DoTickyProfiling = nopC + | otherwise + = ifTicky $ do { bumpTickyCounter SLIT("RET_NEW_ctr") + ; bumpHistogram SLIT("RET_NEW_hst") arity } + +tickyUnboxedTupleReturn :: Int -> Code +tickyUnboxedTupleReturn arity + = ifTicky $ do { bumpTickyCounter SLIT("RET_UNBOXED_TUP_ctr") + ; bumpHistogram SLIT("RET_UNBOXED_TUP_hst") arity } + +tickyVectoredReturn :: Int -> Code +tickyVectoredReturn family_size + = ifTicky $ do { bumpTickyCounter SLIT("VEC_RETURN_ctr") + ; bumpHistogram SLIT("RET_VEC_RETURN_hst") family_size } + +-- ----------------------------------------------------------------------------- +-- Ticky calls + +-- Ticks at a *call site*: +tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter SLIT("KNOWN_CALL_TOO_FEW_ARGS_ctr") +tickyKnownCallExact = ifTicky $ bumpTickyCounter SLIT("KNOWN_CALL_ctr") +tickyKnownCallExtraArgs = ifTicky $ bumpTickyCounter SLIT("KNOWN_CALL_EXTRA_ctr") +tickyUnknownCall = ifTicky $ bumpTickyCounter SLIT("UNKNOWN_CALL_ctr") + +-- Tick for the call pattern at slow call site (i.e. in addition to +-- tickyUnknownCall, tickyKnownCallExtraArgs, etc.) +tickySlowCallPat :: [CgRep] -> Code +tickySlowCallPat args = return () +{- LATER: (introduces recursive module dependency now). + case callPattern args of + (str, True) -> bumpTickyCounter' (mkRtsSlowTickyCtrLabel pat) + (str, False) -> bumpTickyCounter SLIT("TICK_SLOW_CALL_OTHER") + +callPattern :: [CgRep] -> (String,Bool) +callPattern reps + | match == length reps = (chars, True) + | otherwise = (chars, False) + where (_,match) = findMatch reps + chars = map argChar reps + +argChar VoidArg = 'v' +argChar PtrArg = 'p' +argChar NonPtrArg = 'n' +argChar LongArg = 'l' +argChar FloatArg = 'f' +argChar DoubleArg = 'd' +-} + +-- ----------------------------------------------------------------------------- +-- Ticky allocation + +tickyDynAlloc :: ClosureInfo -> Code +-- Called when doing a dynamic heap allocation +tickyDynAlloc cl_info + = ifTicky $ + case smRepClosureType (closureSMRep cl_info) of + Constr -> tick_alloc_con + ConstrNoCaf -> tick_alloc_con + Fun -> tick_alloc_fun + Thunk -> tick_alloc_thk + ThunkSelector -> tick_alloc_thk + where + -- will be needed when we fill in stubs + cl_size = closureSize cl_info + slop_size = slopSize cl_info + + tick_alloc_thk + | closureUpdReqd cl_info = tick_alloc_up_thk + | otherwise = tick_alloc_se_thk + + tick_alloc_con = panic "ToDo: tick_alloc" + tick_alloc_fun = panic "ToDo: tick_alloc" + tick_alloc_up_thk = panic "ToDo: tick_alloc" + tick_alloc_se_thk = panic "ToDo: tick_alloc" + +tickyAllocPrim :: CmmExpr -> CmmExpr -> CmmExpr -> Code +tickyAllocPrim hdr goods slop = ifTicky $ panic "ToDo: tickyAllocPrim" + +tickyAllocThunk :: CmmExpr -> CmmExpr -> Code +tickyAllocThunk goods slop = ifTicky $ panic "ToDo: tickyAllocThunk" + +tickyAllocPAP :: CmmExpr -> CmmExpr -> Code +tickyAllocPAP goods slop = ifTicky $ panic "ToDo: tickyAllocPAP" + +tickyAllocHeap :: VirtualHpOffset -> Code +-- Called when doing a heap check [TICK_ALLOC_HEAP] +tickyAllocHeap hp + = ifTicky $ + do { ticky_ctr <- getTickyCtrLabel + ; stmtsC $ + if hp == 0 then [] -- Inside the stmtC to avoid control + else [ -- dependency on the argument + -- Bump the allcoation count in the StgEntCounter + addToMem REP_StgEntCounter_allocs + (CmmLit (cmmLabelOffB ticky_ctr + oFFSET_StgEntCounter_allocs)) hp, + -- Bump ALLOC_HEAP_ctr + addToMemLbl cLongRep (mkRtsDataLabel SLIT("ALLOC_HEAP_ctr")) 1, + -- Bump ALLOC_HEAP_tot + addToMemLbl cLongRep (mkRtsDataLabel SLIT("ALLOC_HEAP_tot")) hp] } + +-- ----------------------------------------------------------------------------- +-- Ticky utils + +ifTicky :: Code -> Code +ifTicky code + | opt_DoTickyProfiling = code + | otherwise = nopC + +addToMemLbl :: MachRep -> CLabel -> Int -> CmmStmt +addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n + +-- All the ticky-ticky counters are declared "unsigned long" in C +bumpTickyCounter :: LitString -> Code +bumpTickyCounter lbl = bumpTickyCounter' (mkRtsDataLabel lbl) + +bumpTickyCounter' :: CLabel -> Code +bumpTickyCounter' lbl = stmtC (addToMemLbl cLongRep lbl 1) + +addToMemLong = addToMem cLongRep + +bumpHistogram :: LitString -> Int -> Code +bumpHistogram lbl n + = bumpHistogramE lbl (CmmLit (CmmInt (fromIntegral n) cLongRep)) + +bumpHistogramE :: LitString -> CmmExpr -> Code +bumpHistogramE lbl n + = do t <- newTemp cLongRep + stmtC (CmmAssign t n) + emitIf (CmmMachOp (MO_U_Le cLongRep) [CmmReg t, eight]) $ + stmtC (CmmAssign t eight) + stmtC (addToMemLong (cmmIndexExpr cLongRep + (CmmLit (CmmLabel (mkRtsDataLabel lbl))) + (CmmReg t)) + 1) + where + eight = CmmLit (CmmInt 8 cLongRep) + +------------------------------------------------------------------ +-- Showing the "type category" for ticky-ticky profiling + +showTypeCategory :: Type -> Char + {- {C,I,F,D} char, int, float, double + T tuple + S other single-constructor type + {c,i,f,d} unboxed ditto + t *unpacked* tuple + s *unpacked" single-cons... + + v void# + a primitive array + + E enumeration type + + dictionary, unless it's a ... + L List + > function + M other (multi-constructor) data-con type + . other type + - reserved for others to mark as "uninteresting" + -} +showTypeCategory ty + = if isDictTy ty + then '+' + else + case tcSplitTyConApp_maybe ty of + Nothing -> if isJust (tcSplitFunTy_maybe ty) + then '>' + else '.' + + Just (tycon, _) -> + let utc = getUnique tycon in + if utc == charDataConKey then 'C' + else if utc == intDataConKey then 'I' + else if utc == floatDataConKey then 'F' + else if utc == doubleDataConKey then 'D' + else if utc == smallIntegerDataConKey || + utc == largeIntegerDataConKey then 'J' + else if utc == charPrimTyConKey then 'c' + else if (utc == intPrimTyConKey || utc == wordPrimTyConKey + || utc == addrPrimTyConKey) then 'i' + else if utc == floatPrimTyConKey then 'f' + else if utc == doublePrimTyConKey then 'd' + else if isPrimTyCon tycon {- array, we hope -} then 'A' -- Bogus + else if isEnumerationTyCon tycon then 'E' + else if isTupleTyCon tycon then 'T' + else if isJust (maybeTyConSingleCon tycon) then 'S' + else if utc == listTyConKey then 'L' + else 'M' -- oh, well... diff --git a/ghc/compiler/codeGen/CgUpdate.lhs b/ghc/compiler/codeGen/CgUpdate.lhs deleted file mode 100644 index 879dafe4f6..0000000000 --- a/ghc/compiler/codeGen/CgUpdate.lhs +++ /dev/null @@ -1,61 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% -\section[CgUpdate]{Manipulating update frames} - -\begin{code} -module CgUpdate ( pushUpdateFrame ) where - -#include "HsVersions.h" - -import CgMonad -import AbsCSyn - -import CgStackery ( allocStackTop, updateFrameSize, setStackFrame ) -import CgUsages ( getVirtSp ) -import Panic ( assertPanic ) -\end{code} - - -%******************************************************** -%* * -%* Setting up update frames * -%* * -%******************************************************** -\subsection[setting-update-frames]{Setting up update frames} - -@pushUpdateFrame@ $updatee$ pushes a general update frame which -points to $updatee$ as the thing to be updated. It is only used -when a thunk has just been entered, so the (real) stack pointers -are guaranteed to be nicely aligned with the top of stack. -@pushUpdateFrame@ adjusts the virtual and tail stack pointers -to reflect the frame pushed. - -\begin{code} -pushUpdateFrame :: CAddrMode -> Code -> Code - -pushUpdateFrame updatee code - = -#ifdef DEBUG - getEndOfBlockInfo `thenFC` \ eob_info -> - ASSERT(case eob_info of { EndOfBlockInfo _ (OnStack _) -> True; - _ -> False}) -#endif - - allocStackTop updateFrameSize `thenFC` \ _ -> - getVirtSp `thenFC` \ vsp -> - - setStackFrame vsp `thenC` - - setEndOfBlockInfo (EndOfBlockInfo vsp UpdateCode) ( - - -- Emit the push macro - absC (CMacroStmt PUSH_UPD_FRAME [ - updatee, - int_CLit0 -- we just entered a closure, so must be zero - ]) - `thenC` code - ) - -int_CLit0 = mkIntCLit 0 -- out here to avoid pushUpdateFrame CAF (sigh) -\end{code} diff --git a/ghc/compiler/codeGen/CgUsages.lhs b/ghc/compiler/codeGen/CgUsages.lhs deleted file mode 100644 index c8b98f696d..0000000000 --- a/ghc/compiler/codeGen/CgUsages.lhs +++ /dev/null @@ -1,170 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% -\section[CgUsages]{Accessing and modifying stacks and heap usage info} - -This module provides the functions to access (\tr{get*} functions) and -modify (\tr{set*} functions) the stacks and heap usage information. - -\begin{code} -module CgUsages ( - initHeapUsage, setVirtHp, getVirtAndRealHp, setRealHp, - setRealAndVirtualSp, - - getVirtSp, getRealSp, - - getHpRelOffset, getSpRelOffset, - - adjustSpAndHp - ) where - -#include "HsVersions.h" - -import AbsCSyn -import PrimRep ( PrimRep(..) ) -import AbsCUtils ( mkAbstractCs ) -import CgMonad -\end{code} - -%************************************************************************ -%* * -\subsection[CgUsages-heapery]{Monad things for fiddling with heap usage} -%* * -%************************************************************************ - -@initHeapUsage@ applies a function to the amount of heap that it uses. -It initialises the heap usage to zeros, and passes on an unchanged -heap usage. - -It is usually a prelude to performing a GC check, so everything must -be in a tidy and consistent state. - -rje: Note the slightly suble fixed point behaviour needed here -\begin{code} -initHeapUsage :: (VirtualHeapOffset -> Code) -> Code - -initHeapUsage fcode = do - (stk_usage, heap_usage) <- getUsage - setUsage (stk_usage, (0,0)) - fixC (\heap_usage2 -> do - fcode (heapHWM heap_usage2) - (_, heap_usage2) <- getUsage - return heap_usage2) - (stk_usage2, heap_usage2) <- getUsage - setUsage (stk_usage2, heap_usage {-unchanged -}) -\end{code} - -\begin{code} -setVirtHp :: VirtualHeapOffset -> Code -setVirtHp new_virtHp = do - (stk, (virtHp, realHp)) <- getUsage - setUsage (stk, (new_virtHp, realHp)) -\end{code} - -\begin{code} -getVirtAndRealHp :: FCode (VirtualHeapOffset, VirtualHeapOffset) -getVirtAndRealHp = do - (_, (virtHp, realHp)) <- getUsage - return (virtHp, realHp) -\end{code} - -\begin{code} -setRealHp :: VirtualHeapOffset -> Code -setRealHp realHp = do - (stk_usage, (vHp, _)) <- getUsage - setUsage (stk_usage, (vHp, realHp)) -\end{code} - -\begin{code} -getHpRelOffset :: VirtualHeapOffset -> FCode RegRelative -getHpRelOffset virtual_offset = do - (_,(_,realHp)) <- getUsage - return $ hpRel realHp virtual_offset -\end{code} - -The heap high water mark is the larger of virtHp and hwHp. The latter is -only records the high water marks of forked-off branches, so to find the -heap high water mark you have to take the max of virtHp and hwHp. Remember, -virtHp never retreats! - -\begin{code} -heapHWM (virtHp, realHp) = virtHp -\end{code} - -%************************************************************************ -%* * -\subsection[CgUsages-stackery]{Monad things for fiddling with stack usage} -%* * -%************************************************************************ - -@setRealAndVirtualSp@ sets into the environment the offsets of the -current position of the real and virtual stack pointers in the current -stack frame. The high-water mark is set too. It generates no code. -It is used to initialise things at the beginning of a closure body. - -\begin{code} -setRealAndVirtualSp :: VirtualSpOffset -- New real Sp - -> Code - -setRealAndVirtualSp sp = do - ((vsp,frame,f,realSp,hwsp), h_usage) <- getUsage - let new_usage = ((sp, frame, f, sp, sp), h_usage) - setUsage new_usage -\end{code} - -\begin{code} -getVirtSp :: FCode VirtualSpOffset -getVirtSp = do - ((virtSp,_,_,_,_), _) <- getUsage - return virtSp - -getRealSp :: FCode VirtualSpOffset -getRealSp = do - ((_,_,_,realSp,_),_) <- getUsage - return realSp -\end{code} - -\begin{code} -getSpRelOffset :: VirtualSpOffset -> FCode RegRelative -getSpRelOffset virtual_offset = do - ((_,_,_,realSp,_),_) <- getUsage - return $ spRel realSp virtual_offset -\end{code} - -%************************************************************************ -%* * -\subsection[CgStackery-adjust]{Adjusting the stack pointers} -%* * -%************************************************************************ - -This function adjusts the stack and heap pointers just before a tail -call or return. The stack pointer is adjusted to its final position -(i.e. to point to the last argument for a tail call, or the activation -record for a return). The heap pointer may be moved backwards, in -cases where we overallocated at the beginning of the basic block (see -CgCase.lhs for discussion). - -These functions {\em do not} deal with high-water-mark adjustment. -That's done by functions which allocate stack space. - -\begin{code} -adjustSpAndHp :: VirtualSpOffset -- New offset for Arg stack ptr - -> Code -adjustSpAndHp newRealSp = do - (MkCgInfoDown _ _ _ ticky_ctr _) <- getInfoDown - (MkCgState absC binds - ((vSp,frame,fSp,realSp,hwSp), - (vHp, rHp))) <- getState - let move_sp = if (newRealSp == realSp) then AbsCNop - else (CAssign (CReg Sp) - (CAddr (spRel realSp newRealSp))) - let move_hp = - if (rHp == vHp) then AbsCNop - else mkAbstractCs [ - CAssign (CReg Hp) (CAddr (hpRel rHp vHp)), - profCtrAbsC FSLIT("TICK_ALLOC_HEAP") - [ mkIntCLit (vHp - rHp), CLbl ticky_ctr DataPtrRep ] - ] - let new_usage = ((vSp, frame, fSp, newRealSp, hwSp), (vHp,vHp)) - setState $ MkCgState (mkAbstractCs [absC,move_sp,move_hp]) binds new_usage -\end{code} diff --git a/ghc/compiler/codeGen/CgUtils.hs b/ghc/compiler/codeGen/CgUtils.hs new file mode 100644 index 0000000000..e74bd14d1e --- /dev/null +++ b/ghc/compiler/codeGen/CgUtils.hs @@ -0,0 +1,622 @@ +----------------------------------------------------------------------------- +-- +-- Code generator utilities; mostly monadic +-- +-- (c) The University of Glasgow 2004 +-- +----------------------------------------------------------------------------- + +module CgUtils ( + addIdReps, + cgLit, + emitDataLits, emitRODataLits, emitIf, emitIfThenElse, + emitRtsCall, emitRtsCallWithVols, emitRtsCallWithResult, + assignTemp, newTemp, + emitSimultaneously, + emitSwitch, emitLitSwitch, + tagToClosure, + + cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord, + cmmOffsetExprW, cmmOffsetExprB, + cmmRegOffW, cmmRegOffB, + cmmLabelOffW, cmmLabelOffB, + cmmOffsetW, cmmOffsetB, + cmmOffsetLitW, cmmOffsetLitB, + cmmLoadIndexW, + + addToMem, addToMemE, + mkWordCLit, + mkStringCLit, + packHalfWordsCLit, + blankWord + ) where + +#include "HsVersions.h" + +import CgMonad +import TyCon ( TyCon, tyConName ) +import Id ( Id ) +import Constants ( wORD_SIZE ) +import SMRep ( CgRep, StgWord, hALF_WORD_SIZE_IN_BITS, ByteOff, + WordOff, idCgRep ) +import PprCmm ( {- instances -} ) +import Cmm +import CLabel +import CmmUtils +import MachOp ( MachRep(..), wordRep, MachOp(..), MachHint(..), + mo_wordOr, mo_wordAnd, mo_wordNe, mo_wordEq, + mo_wordULt, machRepByteWidth ) +import ForeignCall ( CCallConv(..) ) +import Literal ( Literal(..) ) +import CLabel ( CLabel, mkAsmTempLabel ) +import Digraph ( SCC(..), stronglyConnComp ) +import ListSetOps ( assocDefault ) +import Util ( filterOut, sortLt ) +import Char ( ord ) +import FastString ( LitString, FastString, unpackFS ) +import Outputable + +import DATA_BITS + +#include "../includes/ghcconfig.h" + -- For WORDS_BIGENDIAN + +------------------------------------------------------------------------- +-- +-- Random small functions +-- +------------------------------------------------------------------------- + +addIdReps :: [Id] -> [(CgRep, Id)] +addIdReps ids = [(idCgRep id, id) | id <- ids] + +------------------------------------------------------------------------- +-- +-- Literals +-- +------------------------------------------------------------------------- + +cgLit :: Literal -> FCode CmmLit +cgLit (MachStr s) = mkStringCLit (unpackFS s) +cgLit other_lit = return (mkSimpleLit other_lit) + +mkSimpleLit :: Literal -> CmmLit +mkSimpleLit (MachChar c) = CmmInt (fromIntegral (ord c)) wordRep +mkSimpleLit MachNullAddr = zeroCLit +mkSimpleLit (MachInt i) = CmmInt i wordRep +mkSimpleLit (MachInt64 i) = CmmInt i I64 +mkSimpleLit (MachWord i) = CmmInt i wordRep +mkSimpleLit (MachWord64 i) = CmmInt i I64 +mkSimpleLit (MachFloat r) = CmmFloat r F32 +mkSimpleLit (MachDouble r) = CmmFloat r F64 +mkSimpleLit (MachLabel fs ms) = CmmLabel (mkForeignLabel fs ms is_dyn) + where + is_dyn = False -- ToDo: fix me + +mkLtOp :: Literal -> MachOp +-- On signed literals we must do a signed comparison +mkLtOp (MachInt _) = MO_S_Lt wordRep +mkLtOp (MachFloat _) = MO_S_Lt F32 +mkLtOp (MachDouble _) = MO_S_Lt F64 +mkLtOp lit = MO_U_Lt (cmmLitRep (mkSimpleLit lit)) + + +--------------------------------------------------- +-- +-- Cmm data type functions +-- +--------------------------------------------------- + +----------------------- +-- The "B" variants take byte offsets +cmmRegOffB :: CmmReg -> ByteOff -> CmmExpr +cmmRegOffB = cmmRegOff + +cmmOffsetB :: CmmExpr -> ByteOff -> CmmExpr +cmmOffsetB = cmmOffset + +cmmOffsetExprB :: CmmExpr -> CmmExpr -> CmmExpr +cmmOffsetExprB = cmmOffsetExpr + +cmmLabelOffB :: CLabel -> ByteOff -> CmmLit +cmmLabelOffB = cmmLabelOff + +cmmOffsetLitB :: CmmLit -> ByteOff -> CmmLit +cmmOffsetLitB = cmmOffsetLit + +----------------------- +-- The "W" variants take word offsets +cmmOffsetExprW :: CmmExpr -> CmmExpr -> CmmExpr +-- The second arg is a *word* offset; need to change it to bytes +cmmOffsetExprW e (CmmLit (CmmInt n _)) = cmmOffsetW e (fromInteger n) +cmmOffsetExprW e wd_off = cmmIndexExpr wordRep e wd_off + +cmmOffsetW :: CmmExpr -> WordOff -> CmmExpr +cmmOffsetW e n = cmmOffsetB e (wORD_SIZE * n) + +cmmRegOffW :: CmmReg -> WordOff -> CmmExpr +cmmRegOffW reg wd_off = cmmRegOffB reg (wd_off * wORD_SIZE) + +cmmOffsetLitW :: CmmLit -> WordOff -> CmmLit +cmmOffsetLitW lit wd_off = cmmOffsetLitB lit (wORD_SIZE * wd_off) + +cmmLabelOffW :: CLabel -> WordOff -> CmmLit +cmmLabelOffW lbl wd_off = cmmLabelOffB lbl (wORD_SIZE * wd_off) + +cmmLoadIndexW :: CmmExpr -> Int -> CmmExpr +cmmLoadIndexW base off + = CmmLoad (cmmOffsetW base off) wordRep + +----------------------- +cmmNeWord, cmmEqWord, cmmOrWord, cmmAndWord :: CmmExpr -> CmmExpr -> CmmExpr +cmmOrWord e1 e2 = CmmMachOp mo_wordOr [e1, e2] +cmmAndWord e1 e2 = CmmMachOp mo_wordAnd [e1, e2] +cmmNeWord e1 e2 = CmmMachOp mo_wordNe [e1, e2] +cmmEqWord e1 e2 = CmmMachOp mo_wordEq [e1, e2] +cmmULtWord e1 e2 = CmmMachOp mo_wordULt [e1, e2] + +cmmNegate :: CmmExpr -> CmmExpr +cmmNegate (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep) +cmmNegate e = CmmMachOp (MO_S_Neg (cmmExprRep e)) [e] + +blankWord :: CmmStatic +blankWord = CmmUninitialised wORD_SIZE + +----------------------- +-- Making literals + +mkWordCLit :: StgWord -> CmmLit +mkWordCLit wd = CmmInt (fromIntegral wd) wordRep + +packHalfWordsCLit :: (Integral a, Integral b) => a -> b -> CmmLit +-- Make a single word literal in which the lower_half_word is +-- at the lower address, and the upper_half_word is at the +-- higher address +-- ToDo: consider using half-word lits instead +-- but be careful: that's vulnerable when reversed +packHalfWordsCLit lower_half_word upper_half_word +#ifdef WORDS_BIGENDIAN + = mkWordCLit ((fromIntegral lower_half_word `shiftL` hALF_WORD_SIZE_IN_BITS) + .|. fromIntegral upper_half_word) +#else + = mkWordCLit ((fromIntegral lower_half_word) + .|. (fromIntegral upper_half_word `shiftL` hALF_WORD_SIZE_IN_BITS)) +#endif + +-------------------------------------------------------------------------- +-- +-- Incrementing a memory location +-- +-------------------------------------------------------------------------- + +addToMem :: MachRep -- rep of the counter + -> CmmExpr -- Address + -> Int -- What to add (a word) + -> CmmStmt +addToMem rep ptr n = addToMemE rep ptr (CmmLit (CmmInt (toInteger n) rep)) + +addToMemE :: MachRep -- rep of the counter + -> CmmExpr -- Address + -> CmmExpr -- What to add (a word-typed expression) + -> CmmStmt +addToMemE rep ptr n + = CmmStore ptr (CmmMachOp (MO_Add rep) [CmmLoad ptr rep, n]) + +------------------------------------------------------------------------- +-- +-- Converting a closure tag to a closure for enumeration types +-- (this is the implementation of tagToEnum#). +-- +------------------------------------------------------------------------- + +tagToClosure :: TyCon -> CmmExpr -> CmmExpr +tagToClosure tycon tag + = CmmLoad (cmmOffsetExprW closure_tbl tag) wordRep + where closure_tbl = CmmLit (CmmLabel (mkClosureTblLabel (tyConName tycon))) + +------------------------------------------------------------------------- +-- +-- Conditionals and rts calls +-- +------------------------------------------------------------------------- + +emitIf :: CmmExpr -- Boolean + -> Code -- Then part + -> Code +-- Emit (if e then x) +-- ToDo: reverse the condition to avoid the extra branch instruction if possible +-- (some conditionals aren't reversible. eg. floating point comparisons cannot +-- be inverted because there exist some values for which both comparisons +-- return False, such as NaN.) +emitIf cond then_part + = do { then_id <- newLabelC + ; join_id <- newLabelC + ; stmtC (CmmCondBranch cond then_id) + ; stmtC (CmmBranch join_id) + ; labelC then_id + ; then_part + ; labelC join_id + } + +emitIfThenElse :: CmmExpr -- Boolean + -> Code -- Then part + -> Code -- Else part + -> Code +-- Emit (if e then x else y) +emitIfThenElse cond then_part else_part + = do { then_id <- newLabelC + ; else_id <- newLabelC + ; join_id <- newLabelC + ; stmtC (CmmCondBranch cond then_id) + ; else_part + ; stmtC (CmmBranch join_id) + ; labelC then_id + ; then_part + ; labelC join_id + } + +emitRtsCall :: LitString -> [(CmmExpr,MachHint)] -> Code +emitRtsCall fun args = emitRtsCall' [] fun args Nothing + -- The 'Nothing' says "save all global registers" + +emitRtsCallWithVols :: LitString -> [(CmmExpr,MachHint)] -> [GlobalReg] -> Code +emitRtsCallWithVols fun args vols + = emitRtsCall' [] fun args (Just vols) + +emitRtsCallWithResult :: CmmReg -> MachHint -> LitString + -> [(CmmExpr,MachHint)] -> Code +emitRtsCallWithResult res hint fun args + = emitRtsCall' [(res,hint)] fun args Nothing + +-- Make a call to an RTS C procedure +emitRtsCall' + :: [(CmmReg,MachHint)] + -> LitString + -> [(CmmExpr,MachHint)] + -> Maybe [GlobalReg] + -> Code +emitRtsCall' res fun args vols = stmtC (CmmCall target res args vols) + where + target = CmmForeignCall fun_expr CCallConv + fun_expr = mkLblExpr (mkRtsCodeLabel fun) + + +------------------------------------------------------------------------- +-- +-- Strings gnerate a top-level data block +-- +------------------------------------------------------------------------- + +emitDataLits :: CLabel -> [CmmLit] -> Code +-- Emit a data-segment data block +emitDataLits lbl lits + = emitData Data (CmmDataLabel lbl : map CmmStaticLit lits) + +emitRODataLits :: CLabel -> [CmmLit] -> Code +-- Emit a read-only data block +emitRODataLits lbl lits + = emitData ReadOnlyData (CmmDataLabel lbl : map CmmStaticLit lits) + +mkStringCLit :: String -> FCode CmmLit +-- Make a global definition for the string, +-- and return its label +mkStringCLit str + = do { uniq <- newUnique + ; let lbl = mkAsmTempLabel uniq + ; emitData ReadOnlyData [CmmDataLabel lbl, CmmString str] + ; return (CmmLabel lbl) } + +------------------------------------------------------------------------- +-- +-- Assigning expressions to temporaries +-- +------------------------------------------------------------------------- + +assignTemp :: CmmExpr -> FCode CmmExpr +-- For a non-trivial expression, e, create a local +-- variable and assign the expression to it +assignTemp e + | isTrivialCmmExpr e = return e + | otherwise = do { reg <- newTemp (cmmExprRep e) + ; stmtC (CmmAssign reg e) + ; return (CmmReg reg) } + + +newTemp :: MachRep -> FCode CmmReg +newTemp rep = do { uniq <- newUnique; return (CmmLocal (LocalReg uniq rep)) } + + +------------------------------------------------------------------------- +-- +-- Building case analysis +-- +------------------------------------------------------------------------- + +emitSwitch + :: CmmExpr -- Tag to switch on + -> [(ConTagZ, CgStmts)] -- Tagged branches + -> Maybe CgStmts -- Default branch (if any) + -> ConTagZ -> ConTagZ -- Min and Max possible values; behaviour + -- outside this range is undefined + -> Code + +-- ONLY A DEFAULT BRANCH: no case analysis to do +emitSwitch tag_expr [] (Just stmts) _ _ + = emitCgStmts stmts + +-- Right, off we go +emitSwitch tag_expr branches mb_deflt lo_tag hi_tag + = -- Just sort the branches before calling mk_sritch + do { mb_deflt_id <- + case mb_deflt of + Nothing -> return Nothing + Just stmts -> do id <- forkCgStmts stmts; return (Just id) + + ; stmts <- mk_switch tag_expr (sortLt lt branches) + mb_deflt_id lo_tag hi_tag + ; emitCgStmts stmts + } + where + (t1,_) `lt` (t2,_) = t1 < t2 + + +mk_switch :: CmmExpr -> [(ConTagZ, CgStmts)] + -> Maybe BlockId -> ConTagZ -> ConTagZ + -> FCode CgStmts + +-- SINGLETON TAG RANGE: no case analysis to do +mk_switch tag_expr [(tag,stmts)] _ lo_tag hi_tag + | lo_tag == hi_tag + = ASSERT( tag == lo_tag ) + return stmts + +-- SINGLETON BRANCH, NO DEFUALT: no case analysis to do +mk_switch tag_expr [(tag,stmts)] Nothing lo_tag hi_tag + = return stmts + -- The simplifier might have eliminated a case + -- so we may have e.g. case xs of + -- [] -> e + -- In that situation we can be sure the (:) case + -- can't happen, so no need to test + +-- SINGLETON BRANCH: one equality check to do +mk_switch tag_expr [(tag,stmts)] (Just deflt) lo_tag hi_tag + = return (CmmCondBranch cond deflt `consCgStmt` stmts) + where + cond = cmmNeWord tag_expr (CmmLit (mkIntCLit tag)) + -- We have lo_tag < hi_tag, but there's only one branch, + -- so there must be a default + +-- ToDo: we might want to check for the two branch case, where one of +-- the branches is the tag 0, because comparing '== 0' is likely to be +-- more efficient than other kinds of comparison. + +-- DENSE TAG RANGE: use a switch statment +mk_switch tag_expr branches mb_deflt lo_tag hi_tag + | use_switch -- Use a switch + = do { deflt_id <- get_deflt_id mb_deflt + ; branch_ids <- mapM forkCgStmts (map snd branches) + ; let + tagged_blk_ids = zip (map fst branches) branch_ids + + find_branch :: BlockId -> ConTagZ -> BlockId + find_branch deflt_id i = assocDefault deflt_id tagged_blk_ids i + + arms = [ Just (find_branch deflt_id (i+lo_tag)) + | i <- [0..n_tags-1]] + + switch_stmt = CmmSwitch (cmmOffset tag_expr (- lo_tag)) arms + + ; return (oneCgStmt switch_stmt) + } + + | otherwise -- Use an if-tree + = do { (assign_tag, tag_expr') <- assignTemp' tag_expr + -- To avoid duplication + ; lo_stmts <- mk_switch tag_expr' lo_branches mb_deflt lo_tag (mid_tag-1) + ; hi_stmts <- mk_switch tag_expr' hi_branches mb_deflt mid_tag hi_tag + ; lo_id <- forkCgStmts lo_stmts + ; let cond = cmmULtWord tag_expr' (CmmLit (mkIntCLit mid_tag)) + branch_stmt = CmmCondBranch cond lo_id + ; return (assign_tag `consCgStmt` (branch_stmt `consCgStmt` hi_stmts)) + } + where + use_switch = ASSERT( n_branches > 1 && n_tags > 1 ) + n_tags > 2 && (small || dense) + -- a 2-branch switch always turns into an if. + small = n_tags <= 4 + dense = n_branches > (n_tags `div` 2) + exhaustive = n_tags == n_branches + n_tags = hi_tag - lo_tag + 1 + n_branches = length branches + + -- INVARIANT: Provided hi_tag > lo_tag (which is true) + -- lo_tag <= mid_tag < hi_tag + -- lo_branches have tags < mid_tag + -- hi_branches have tags >= mid_tag + + (mid_tag,_) = branches !! (n_branches `div` 2) + -- 2 branches => n_branches `div` 2 = 1 + -- => branches !! 1 give the *second* tag + -- There are always at least 2 branches here + + (lo_branches, hi_branches) = span is_lo branches + is_lo (t,_) = t < mid_tag + + -- Add a default block if the case is not exhaustive + get_deflt_id (Just deflt_id) = return deflt_id + get_deflt_id Nothing + | exhaustive + = return (pprPanic "mk_deflt_blks" (ppr tag_expr)) + | otherwise + = do { stmts <- getCgStmts (stmtC jump_to_impossible) + ; id <- forkCgStmts stmts + ; return id } + + jump_to_impossible + = CmmJump (mkLblExpr mkErrorStdEntryLabel) [] + + +assignTemp' e + | isTrivialCmmExpr e = return (CmmNop, e) + | otherwise = do { reg <- newTemp (cmmExprRep e) + ; return (CmmAssign reg e, CmmReg reg) } + + +emitLitSwitch :: CmmExpr -- Tag to switch on + -> [(Literal, CgStmts)] -- Tagged branches + -> CgStmts -- Default branch (always) + -> Code -- Emit the code +-- Used for general literals, whose size might not be a word, +-- where there is always a default case, and where we don't know +-- the range of values for certain. For simplicity we always generate a tree. +emitLitSwitch scrut [] deflt + = emitCgStmts deflt +emitLitSwitch scrut branches deflt_blk + = do { scrut' <- assignTemp scrut + ; deflt_blk_id <- forkCgStmts deflt_blk + ; blk <- mk_lit_switch scrut' deflt_blk_id (sortLt lt branches) + ; emitCgStmts blk } + where + lt (t1,_) (t2,_) = t1 < t2 + +mk_lit_switch :: CmmExpr -> BlockId + -> [(Literal,CgStmts)] + -> FCode CgStmts +mk_lit_switch scrut deflt_blk_id [(lit,blk)] + = return (consCgStmt if_stmt blk) + where + cmm_lit = mkSimpleLit lit + rep = cmmLitRep cmm_lit + cond = CmmMachOp (MO_Ne rep) [scrut, CmmLit cmm_lit] + if_stmt = CmmCondBranch cond deflt_blk_id + +mk_lit_switch scrut deflt_blk_id branches + = do { hi_blk <- mk_lit_switch scrut deflt_blk_id hi_branches + ; lo_blk <- mk_lit_switch scrut deflt_blk_id lo_branches + ; lo_blk_id <- forkCgStmts lo_blk + ; let if_stmt = CmmCondBranch cond lo_blk_id + ; return (if_stmt `consCgStmt` hi_blk) } + where + n_branches = length branches + (mid_lit,_) = branches !! (n_branches `div` 2) + -- See notes above re mid_tag + + (lo_branches, hi_branches) = span is_lo branches + is_lo (t,_) = t < mid_lit + + cond = CmmMachOp (mkLtOp mid_lit) + [scrut, CmmLit (mkSimpleLit mid_lit)] + +------------------------------------------------------------------------- +-- +-- Simultaneous assignment +-- +------------------------------------------------------------------------- + + +emitSimultaneously :: CmmStmts -> Code +-- Emit code to perform the assignments in the +-- input simultaneously, using temporary variables when necessary. +-- +-- The Stmts must be: +-- CmmNop, CmmComment, CmmAssign, CmmStore +-- and nothing else + + +-- We use the strongly-connected component algorithm, in which +-- * the vertices are the statements +-- * an edge goes from s1 to s2 iff +-- s1 assigns to something s2 uses +-- that is, if s1 should *follow* s2 in the final order + +type CVertex = (Int, CmmStmt) -- Give each vertex a unique number, + -- for fast comparison + +emitSimultaneously stmts + = codeOnly $ + case filterOut isNopStmt (stmtList stmts) of + -- Remove no-ops + [] -> nopC + [stmt] -> stmtC stmt -- It's often just one stmt + stmt_list -> doSimultaneously1 (zip [(1::Int)..] stmt_list) + +doSimultaneously1 :: [CVertex] -> Code +doSimultaneously1 vertices + = let + edges = [ (vertex, key1, edges_from stmt1) + | vertex@(key1, stmt1) <- vertices + ] + edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices, + stmt1 `mustFollow` stmt2 + ] + components = stronglyConnComp edges + + -- do_components deal with one strongly-connected component + -- Not cyclic, or singleton? Just do it + do_component (AcyclicSCC (n,stmt)) = stmtC stmt + do_component (CyclicSCC [(n,stmt)]) = stmtC stmt + + -- Cyclic? Then go via temporaries. Pick one to + -- break the loop and try again with the rest. + do_component (CyclicSCC ((n,first_stmt) : rest)) + = do { from_temp <- go_via_temp first_stmt + ; doSimultaneously1 rest + ; stmtC from_temp } + + go_via_temp (CmmAssign dest src) + = do { tmp <- newTemp (cmmRegRep dest) + ; stmtC (CmmAssign tmp src) + ; return (CmmAssign dest (CmmReg tmp)) } + go_via_temp (CmmStore dest src) + = do { tmp <- newTemp (cmmExprRep src) + ; stmtC (CmmAssign tmp src) + ; return (CmmStore dest (CmmReg tmp)) } + in + mapCs do_component components + +mustFollow :: CmmStmt -> CmmStmt -> Bool +CmmAssign reg _ `mustFollow` stmt = anySrc (reg `regUsedIn`) stmt +CmmStore loc e `mustFollow` stmt = anySrc (locUsedIn loc (cmmExprRep e)) stmt +CmmNop `mustFollow` stmt = False +CmmComment _ `mustFollow` stmt = False + + +anySrc :: (CmmExpr -> Bool) -> CmmStmt -> Bool +-- True if the fn is true of any input of the stmt +anySrc p (CmmAssign _ e) = p e +anySrc p (CmmStore e1 e2) = p e1 || p e2 -- Might be used in either side +anySrc p (CmmComment _) = False +anySrc p CmmNop = False +anySrc p other = True -- Conservative + +regUsedIn :: CmmReg -> CmmExpr -> Bool +reg `regUsedIn` CmmLit _ = False +reg `regUsedIn` CmmLoad e _ = reg `regUsedIn` e +reg `regUsedIn` CmmReg reg' = reg == reg' +reg `regUsedIn` CmmRegOff reg' _ = reg == reg' +reg `regUsedIn` CmmMachOp _ es = any (reg `regUsedIn`) es + +locUsedIn :: CmmExpr -> MachRep -> CmmExpr -> Bool +-- (locUsedIn a r e) checks whether writing to r[a] could affect the value of +-- 'e'. Returns True if it's not sure. +locUsedIn loc rep (CmmLit _) = False +locUsedIn loc rep (CmmLoad e ld_rep) = possiblySameLoc loc rep e ld_rep +locUsedIn loc rep (CmmReg reg') = False +locUsedIn loc rep (CmmRegOff reg' _) = False +locUsedIn loc rep (CmmMachOp _ es) = any (locUsedIn loc rep) es + +possiblySameLoc :: CmmExpr -> MachRep -> CmmExpr -> MachRep -> Bool +-- Assumes that distinct registers (eg Hp, Sp) do not +-- point to the same location, nor any offset thereof. +possiblySameLoc (CmmReg r1) rep1 (CmmReg r2) rep2 = r1==r2 +possiblySameLoc (CmmReg r1) rep1 (CmmRegOff r2 0) rep2 = r1==r2 +possiblySameLoc (CmmRegOff r1 0) rep1 (CmmReg r2) rep2 = r1==r2 +possiblySameLoc (CmmRegOff r1 start1) rep1 (CmmRegOff r2 start2) rep2 + = r1==r2 && end1 > start2 && end2 > start1 + where + end1 = start1 + machRepByteWidth rep1 + end2 = start2 + machRepByteWidth rep2 + +possiblySameLoc l1 rep1 (CmmLit _) rep2 = False +possiblySameLoc l1 rep1 l2 rep2 = True -- Conservative diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs index 86380ecaa6..0abf831c51 100644 --- a/ghc/compiler/codeGen/ClosureInfo.lhs +++ b/ghc/compiler/codeGen/ClosureInfo.lhs @@ -1,9 +1,11 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% (c) The Univserity of Glasgow 1992-2004 % -% $Id: ClosureInfo.lhs,v 1.62 2004/03/31 15:23:17 simonmar Exp $ -% -\section[ClosureInfo]{Data structures which describe closures} + + Data structures which describe closures, and + operations over those data structures + + Nothing monadic in here Much of the rationale for these things is in the ``details'' part of the STG paper. @@ -11,86 +13,73 @@ the STG paper. \begin{code} module ClosureInfo ( ClosureInfo, LambdaFormInfo, SMRep, -- all abstract - StandardFormInfo, ArgDescr(..), + StandardFormInfo, - CallingConvention(..), + ArgDescr(..), Liveness(..), + C_SRT(..), needsSRT, - mkClosureLFInfo, mkConLFInfo, mkSelectorLFInfo, + mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo, mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape, + mkClosureInfo, mkConInfo, + closureSize, closureNonHdrSize, closureGoodStuffSize, closurePtrsSize, - slopSize, + slopSize, - layOutDynClosure, layOutStaticClosure, layOutStaticNoFVClosure, - layOutDynConstr, layOutStaticConstr, - mkVirtHeapOffsets, mkStaticClosure, + closureName, infoTableLabelFromCI, + closureLabelFromCI, closureSRT, + closureLFInfo, closureSMRep, closureUpdReqd, + closureSingleEntry, closureReEntrant, isConstrClosure_maybe, + closureFunInfo, isStandardFormThunk, isKnownFun, - nodeMustPointToIt, getEntryConvention, - FCode, CgInfoDownwards, CgState, + enterIdLabel, enterReturnPtLabel, + + nodeMustPointToIt, + CallMethod(..), getCallMethod, blackHoleOnEntry, staticClosureRequired, - - closureName, infoTableLabelFromCI, - closureLabelFromCI, closureSRT, - entryLabelFromCI, - closureLFInfo, closureSMRep, closureUpdReqd, - closureSingleEntry, closureReEntrant, closureSemiTag, - closureFunInfo, isStandardFormThunk, + getClosureType, isToplevClosure, - closureTypeDescr, -- profiling + closureValDescr, closureTypeDescr, -- profiling isStaticClosure, - allocProfilingMsg, cafBlackHoleClosureInfo, seCafBlackHoleClosureInfo, staticClosureNeedsLink, - - mkInfoTable, mkRetInfoTable, mkVecInfoTable, ) where -#include "../includes/config.h" #include "../includes/MachDeps.h" #include "HsVersions.h" -import AbsCSyn import StgSyn -import CgMonad +import SMRep -- all of it -import Constants ( mIN_UPD_SIZE, mIN_SIZE_NonUpdHeapObject ) -import CgRetConv ( assignRegs ) import CLabel + +import Constants ( mIN_UPD_SIZE, mIN_SIZE_NonUpdHeapObject ) import CmdLineOpts ( opt_SccProfilingOn, opt_OmitBlackHoling, opt_Parallel, opt_DoTickyProfiling, - opt_SMP, opt_Unregisterised ) -import Id ( Id, idType, idArity, idName, idPrimRep ) -import DataCon ( DataCon, dataConTag, fIRST_TAG, dataConTyCon, - isNullaryDataCon, dataConName - ) -import Name ( Name, nameUnique, getOccName, getName, getOccString ) + opt_SMP ) +import Id ( Id, idType, idArity, idName ) +import DataCon ( DataCon, dataConTyCon, isNullaryDataCon, dataConName ) +import Name ( Name, nameUnique, getOccName, getOccString ) import OccName ( occNameUserString ) -import PrimRep -import SMRep -- all of it import Type ( isUnLiftedType, Type, repType, splitTyConApp_maybe ) import TcType ( tcSplitSigmaTy ) import TyCon ( isFunTyCon, isAbstractTyCon ) import BasicTypes ( TopLevelFlag(..), isNotTopLevel, isTopLevel, ipNameName ) -import Util ( mapAccumL, listLengthCmp, lengthIs ) import FastString import Outputable -import Literal import Constants -import Bitmap - -import Maybe ( isJust ) -import DATA_BITS import TypeRep -- TEMP \end{code} + %************************************************************************ %* * \subsection[ClosureInfo-datatypes]{Data types for closure information} @@ -121,12 +110,22 @@ data ClosureInfo closureDescr :: !String -- closure description (for profiling) } - -- constructor closures don't have a unique info table label (they use + -- Constructor closures don't have a unique info table label (they use -- the constructor's info table), and they don't have an SRT. | ConInfo { closureCon :: !DataCon, closureSMRep :: !SMRep } + +-- C_SRT is what StgSyn.SRT gets translated to... +-- we add a label for the table, and expect only the 'offset/length' form + +data C_SRT = NoC_SRT + | C_SRT !CLabel !WordOff !StgHalfWord {-bitmap or escape-} + +needsSRT :: C_SRT -> Bool +needsSRT NoC_SRT = False +needsSRT (C_SRT _ _ _) = True \end{code} %************************************************************************ @@ -147,11 +146,11 @@ ClosureInfo contains a LambdaFormInfo. data LambdaFormInfo = LFReEntrant -- Reentrant closure (a function) TopLevelFlag -- True if top level - !Int -- Arity + !Int -- Arity. Invariant: always > 0 !Bool -- True <=> no fvs ArgDescr -- Argument descriptor (should reall be in ClosureInfo) - | LFCon -- Constructor + | LFCon -- A saturated constructor application DataCon -- The constructor | LFThunk -- Thunk (zero arity) @@ -179,36 +178,58 @@ data LambdaFormInfo CLabel -- Flavour (info label, eg CAF_BLACKHOLE_info). -data StandardFormInfo -- Tells whether this thunk has one of a small number - -- of standard forms +------------------------- +-- An ArgDsecr describes the argument pattern of a function - = NonStandardThunk -- No, it isn't +data ArgDescr + = ArgSpec -- Fits one of the standard patterns + !Int -- RTS type identifier ARG_P, ARG_N, ... - | SelectorThunk - Int -- 0-origin offset of ak within the "goods" of - -- constructor (Recall that the a1,...,an may be laid - -- out in the heap in a non-obvious order.) + | ArgGen -- General case + Liveness -- Details about the arguments -{- A SelectorThunk is of form - case x of - con a1,..,an -> ak +------------------------- +-- We represent liveness bitmaps as a Bitmap (whose internal +-- representation really is a bitmap). These are pinned onto case return +-- vectors to indicate the state of the stack for the garbage collector. +-- +-- In the compiled program, liveness bitmaps that fit inside a single +-- word (StgWord) are stored as a single word, while larger bitmaps are +-- stored as a pointer to an array of words. - and the constructor is from a single-constr type. --} +data Liveness + = SmallLiveness -- Liveness info that fits in one word + StgWord -- Here's the bitmap + + | BigLiveness -- Liveness info witha a multi-word bitmap + CLabel -- Label for the bitmap - | ApThunk - Int -- arity -{- An ApThunk is of form +------------------------- +-- StandardFormInfo tells whether this thunk has one of +-- a small number of standard forms - x1 ... xn +data StandardFormInfo + = NonStandardThunk + -- Not of of the standard forms - The code for the thunk just pushes x2..xn on the stack and enters x1. - There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled - in the RTS to save space. --} + | SelectorThunk + -- A SelectorThunk is of form + -- case x of + -- con a1,..,an -> ak + -- and the constructor is from a single-constr type. + WordOff -- 0-origin offset of ak within the "goods" of + -- constructor (Recall that the a1,...,an may be laid + -- out in the heap in a non-obvious order.) + | ApThunk + -- An ApThunk is of form + -- x1 ... xn + -- The code for the thunk just pushes x2..xn on the stack and enters x1. + -- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled + -- in the RTS to save space. + Int -- Arity, n \end{code} %************************************************************************ @@ -217,31 +238,27 @@ data StandardFormInfo -- Tells whether this thunk has one of a small number %* * %************************************************************************ -@mkClosureLFInfo@ figures out the appropriate LFInfo for the closure. - \begin{code} -mkClosureLFInfo :: Id -- The binder - -> TopLevelFlag -- True of top level - -> [Id] -- Free vars - -> UpdateFlag -- Update flag - -> [Id] -- Args - -> LambdaFormInfo - -mkClosureLFInfo bndr top fvs upd_flag args@(_:_) -- Non-empty args - = LFReEntrant top (length args) (null fvs) (mkArgDescr (getName bndr) args) - -mkClosureLFInfo bndr top fvs upd_flag [] - = ASSERT( not updatable || not (isUnLiftedType id_ty) ) - LFThunk top (null fvs) updatable NonStandardThunk - (might_be_a_function id_ty) - where - updatable = isUpdatable upd_flag - id_ty = idType bndr +mkLFReEntrant :: TopLevelFlag -- True of top level + -> [Id] -- Free vars + -> [Id] -- Args + -> ArgDescr -- Argument descriptor + -> LambdaFormInfo + +mkLFReEntrant top fvs args arg_descr + = LFReEntrant top (length args) (null fvs) arg_descr + +mkLFThunk thunk_ty top fvs upd_flag + = ASSERT( not (isUpdatable upd_flag) || not (isUnLiftedType thunk_ty) ) + LFThunk top (null fvs) + (isUpdatable upd_flag) + NonStandardThunk + (might_be_a_function thunk_ty) might_be_a_function :: Type -> Bool might_be_a_function ty | Just (tc,_) <- splitTyConApp_maybe (repType ty), - not (isFunTyCon tc) && not (isAbstractTyCon tc) = False + not (isFunTyCon tc) && not (isAbstractTyCon tc) = False -- don't forget to check for abstract types, which might -- be functions too. | otherwise = True @@ -276,6 +293,42 @@ mkLFImported id other -> mkLFArgument id -- Not sure of exact arity \end{code} +%************************************************************************ +%* * + Building ClosureInfos +%* * +%************************************************************************ + +\begin{code} +mkClosureInfo :: Bool -- Is static + -> Id + -> LambdaFormInfo + -> Int -> Int -- Total and pointer words + -> C_SRT + -> String -- String descriptor + -> ClosureInfo +mkClosureInfo is_static id lf_info tot_wds ptr_wds srt_info descr + = ClosureInfo { closureName = name, + closureLFInfo = lf_info, + closureSMRep = sm_rep, + closureSRT = srt_info, + closureType = idType id, + closureDescr = descr } + where + name = idName id + sm_rep = chooseSMRep is_static lf_info tot_wds ptr_wds + +mkConInfo :: Bool -- Is static + -> DataCon + -> Int -> Int -- Total and pointer words + -> ClosureInfo +mkConInfo is_static data_con tot_wds ptr_wds + = ConInfo { closureSMRep = sm_rep, + closureCon = data_con } + where + sm_rep = chooseSMRep is_static (mkConLFInfo data_con) tot_wds ptr_wds +\end{code} + %************************************************************************ %* * \subsection[ClosureInfo-sizes]{Functions about closure {\em sizes}} @@ -283,10 +336,10 @@ mkLFImported id %************************************************************************ \begin{code} -closureSize :: ClosureInfo -> HeapOffset +closureSize :: ClosureInfo -> WordOff closureSize cl_info = fixedHdrSize + closureNonHdrSize cl_info -closureNonHdrSize :: ClosureInfo -> Int +closureNonHdrSize :: ClosureInfo -> WordOff closureNonHdrSize cl_info = tot_wds + computeSlopSize tot_wds (closureSMRep cl_info) @@ -302,24 +355,24 @@ closureNeedsUpdSpace (ClosureInfo { closureLFInfo = LFThunk TopLevel _ _ _ _ }) = True closureNeedsUpdSpace cl_info = closureUpdReqd cl_info -slopSize :: ClosureInfo -> Int +slopSize :: ClosureInfo -> WordOff slopSize cl_info = computeSlopSize (closureGoodStuffSize cl_info) (closureSMRep cl_info) (closureNeedsUpdSpace cl_info) -closureGoodStuffSize :: ClosureInfo -> Int +closureGoodStuffSize :: ClosureInfo -> WordOff closureGoodStuffSize cl_info = let (ptrs, nonptrs) = sizes_from_SMRep (closureSMRep cl_info) in ptrs + nonptrs -closurePtrsSize :: ClosureInfo -> Int +closurePtrsSize :: ClosureInfo -> WordOff closurePtrsSize cl_info = let (ptrs, _) = sizes_from_SMRep (closureSMRep cl_info) in ptrs -- not exported: -sizes_from_SMRep :: SMRep -> (Int,Int) +sizes_from_SMRep :: SMRep -> (WordOff,WordOff) sizes_from_SMRep (GenericRep _ ptrs nonptrs _) = (ptrs, nonptrs) sizes_from_SMRep BlackHoleRep = (0, 0) \end{code} @@ -353,7 +406,7 @@ Static closures have an extra ``static link field'' at the end, but we don't bother taking that into account here. \begin{code} -computeSlopSize :: Int -> SMRep -> Bool -> Int +computeSlopSize :: WordOff -> SMRep -> Bool -> WordOff computeSlopSize tot_wds (GenericRep _ _ _ _) True -- Updatable = max 0 (mIN_UPD_SIZE - tot_wds) @@ -368,129 +421,6 @@ computeSlopSize tot_wds BlackHoleRep _ -- Updatable = max 0 (mIN_UPD_SIZE - tot_wds) \end{code} -%************************************************************************ -%* * -\subsection[layOutDynClosure]{Lay out a closure} -%* * -%************************************************************************ - -\begin{code} -layOutDynClosure, layOutStaticClosure - :: Id -- STG identifier of this closure - -> (a -> PrimRep) -- how to get a PrimRep for the fields - -> [a] -- the "things" being layed out - -> LambdaFormInfo -- what sort of closure it is - -> C_SRT -- its SRT - -> String -- closure description - -> (ClosureInfo, -- info about the closure - [(a, VirtualHeapOffset)]) -- things w/ offsets pinned on them - -layOutDynClosure = layOutClosure False -layOutStaticClosure = layOutClosure True - -layOutStaticNoFVClosure id lf_info srt_info descr - = fst (layOutClosure True id (panic "kind_fn") [] lf_info srt_info descr) - -layOutClosure - :: Bool -- True <=> static closure - -> Id -- STG identifier of this closure - -> (a -> PrimRep) -- how to get a PrimRep for the fields - -> [a] -- the "things" being layed out - -> LambdaFormInfo -- what sort of closure it is - -> C_SRT -- its SRT - -> String -- closure description - -> (ClosureInfo, -- info about the closure - [(a, VirtualHeapOffset)]) -- things w/ offsets pinned on them - -layOutClosure is_static id kind_fn things lf_info srt_info descr - = (ClosureInfo { closureName = name, - closureLFInfo = lf_info, - closureSMRep = sm_rep, - closureSRT = srt_info, - closureType = idType id, - closureDescr = descr }, - things_w_offsets) - where - name = idName id - (tot_wds, -- #ptr_wds + #nonptr_wds - ptr_wds, -- #ptr_wds - things_w_offsets) = mkVirtHeapOffsets kind_fn things - sm_rep = chooseSMRep is_static lf_info tot_wds ptr_wds - - -layOutDynConstr, layOutStaticConstr - :: DataCon - -> (a -> PrimRep) - -> [a] - -> (ClosureInfo, - [(a,VirtualHeapOffset)]) - -layOutDynConstr = layOutConstr False -layOutStaticConstr = layOutConstr True - -layOutConstr is_static data_con kind_fn args - = (ConInfo { closureSMRep = sm_rep, - closureCon = data_con }, - things_w_offsets) - where - (tot_wds, -- #ptr_wds + #nonptr_wds - ptr_wds, -- #ptr_wds - things_w_offsets) = mkVirtHeapOffsets kind_fn args - sm_rep = chooseSMRep is_static (mkConLFInfo data_con) tot_wds ptr_wds -\end{code} - -%************************************************************************ -%* * -\subsection[mkStaticClosure]{Make a static closure} -%* * -%************************************************************************ - -Make a static closure, adding on any extra padding needed for CAFs, -and adding a static link field if necessary. - -\begin{code} -mkStaticClosure lbl cl_info ccs fields cafrefs - | opt_SccProfilingOn = - CStaticClosure - lbl - cl_info - (mkCCostCentreStack ccs) - all_fields - | otherwise = - CStaticClosure - lbl - cl_info - (panic "absent cc") - all_fields - - where - all_fields = fields ++ padding_wds ++ static_link_field - - upd_reqd = closureUpdReqd cl_info - - -- for the purposes of laying out the static closure, we consider all - -- thunks to be "updatable", so that the static link field is always - -- in the same place. - padding_wds - | not upd_reqd = [] - | otherwise = replicate n (mkIntCLit 0) -- a bunch of 0s - where n = max 0 (mIN_UPD_SIZE - length fields) - - -- We always have a static link field for a thunk, it's used to - -- save the closure's info pointer when we're reverting CAFs - -- (see comment in Storage.c) - static_link_field - | upd_reqd || staticClosureNeedsLink cl_info = [static_link_value] - | otherwise = [] - - -- for a static constructor which has NoCafRefs, we set the - -- static link field to a non-zero value so the garbage - -- collector will ignore it. - static_link_value - | cafrefs = mkIntCLit 0 - | otherwise = mkIntCLit 1 -\end{code} - %************************************************************************ %* * \subsection[SMreps]{Choosing SM reps} @@ -501,23 +431,23 @@ mkStaticClosure lbl cl_info ccs fields cafrefs chooseSMRep :: Bool -- True <=> static closure -> LambdaFormInfo - -> Int -> Int -- Tot wds, ptr wds + -> WordOff -> WordOff -- Tot wds, ptr wds -> SMRep chooseSMRep is_static lf_info tot_wds ptr_wds = let nonptr_wds = tot_wds - ptr_wds - closure_type = getClosureType is_static tot_wds ptr_wds lf_info + closure_type = getClosureType is_static ptr_wds lf_info in GenericRep is_static ptr_wds nonptr_wds closure_type --- we *do* get non-updatable top-level thunks sometimes. eg. f = g +-- We *do* get non-updatable top-level thunks sometimes. eg. f = g -- gets compiled to a jump to g (if g has non-zero arity), instead of -- messing around with update frames and PAPs. We set the closure type -- to FUN_STATIC in this case. -getClosureType :: Bool -> Int -> Int -> LambdaFormInfo -> ClosureType -getClosureType is_static tot_wds ptr_wds lf_info +getClosureType :: Bool -> WordOff -> LambdaFormInfo -> ClosureType +getClosureType is_static ptr_wds lf_info = case lf_info of LFCon con | is_static && ptr_wds == 0 -> ConstrNoCaf | otherwise -> Constr @@ -527,42 +457,6 @@ getClosureType is_static tot_wds ptr_wds lf_info _ -> panic "getClosureType" \end{code} -%************************************************************************ -%* * -\subsection[mkVirtHeapOffsets]{Assigning heap offsets in a closure} -%* * -%************************************************************************ - -@mkVirtHeapOffsets@ (the heap version) always returns boxed things with -smaller offsets than the unboxed things, and furthermore, the offsets in -the result list - -\begin{code} -mkVirtHeapOffsets :: - (a -> PrimRep) -- To be able to grab kinds; - -- w/ a kind, we can find boxedness - -> [a] -- Things to make offsets for - -> (Int, -- *Total* number of words allocated - Int, -- Number of words allocated for *pointers* - [(a, VirtualHeapOffset)]) - -- Things with their offsets from start of - -- object in order of increasing offset - --- First in list gets lowest offset, which is initial offset + 1. - -mkVirtHeapOffsets kind_fun things - = let (ptrs, non_ptrs) = separateByPtrFollowness kind_fun things - (wds_of_ptrs, ptrs_w_offsets) = mapAccumL computeOffset 0 ptrs - (tot_wds, non_ptrs_w_offsets) = mapAccumL computeOffset wds_of_ptrs non_ptrs - in - (tot_wds, wds_of_ptrs, ptrs_w_offsets ++ non_ptrs_w_offsets) - where - computeOffset wds_so_far thing - = (wds_so_far + (getPrimRepSize . kind_fun) thing, - (thing, fixedHdrSize + wds_so_far) - ) -\end{code} - %************************************************************************ %* * \subsection[ClosureInfo-4-questions]{Four major questions about @ClosureInfo@} @@ -572,13 +466,10 @@ mkVirtHeapOffsets kind_fun things Be sure to see the stg-details notes about these... \begin{code} -nodeMustPointToIt :: LambdaFormInfo -> FCode Bool -nodeMustPointToIt lf_info - - = case lf_info of - LFReEntrant top _ no_fvs _ -> returnFC ( - not no_fvs || -- Certainly if it has fvs we need to point to it - isNotTopLevel top +nodeMustPointToIt :: LambdaFormInfo -> Bool +nodeMustPointToIt (LFReEntrant top _ no_fvs _) + = not no_fvs || -- Certainly if it has fvs we need to point to it + isNotTopLevel top -- If it is not top level we will point to it -- We can have a \r closure with no_fvs which -- is not top level as special case cgRhsClosure @@ -587,9 +478,8 @@ nodeMustPointToIt lf_info -- For lex_profiling we also access the cost centre for a -- non-inherited function i.e. not top level -- the not top case above ensures this is ok. - ) - LFCon _ -> returnFC True +nodeMustPointToIt (LFCon _) = True -- Strictly speaking, the above two don't need Node to point -- to it if the arity = 0. But this is a *really* unlikely @@ -602,9 +492,8 @@ nodeMustPointToIt lf_info -- having Node point to the result of an update. SLPJ -- 27/11/92. - LFThunk _ no_fvs updatable NonStandardThunk _ - -> returnFC (updatable || not no_fvs || opt_SccProfilingOn) - +nodeMustPointToIt (LFThunk _ no_fvs updatable NonStandardThunk _) + = updatable || not no_fvs || opt_SccProfilingOn -- For the non-updatable (single-entry case): -- -- True if has fvs (in which case we need access to them, and we @@ -612,15 +501,12 @@ nodeMustPointToIt lf_info -- or profiling (in which case we need to recover the cost centre -- from inside it) - LFThunk _ no_fvs updatable some_standard_form_thunk _ - -> returnFC True - -- Node must point to any standard-form thunk. +nodeMustPointToIt (LFThunk _ no_fvs updatable some_standard_form_thunk _) + = True -- Node must point to any standard-form thunk - LFUnknown _ -> returnFC True - LFBlackHole _ -> returnFC True - -- BH entry may require Node to point - - LFLetNoEscape _ -> returnFC False +nodeMustPointToIt (LFUnknown _) = True +nodeMustPointToIt (LFBlackHole _) = True -- BH entry may require Node to point +nodeMustPointToIt (LFLetNoEscape _) = False \end{code} The entry conventions depend on the type of closure being entered, @@ -652,7 +538,7 @@ When black-holing, single-entry closures could also be entered via node (rather than directly) to catch double-entry. \begin{code} -data CallingConvention +data CallMethod = EnterIt -- no args, not a function | JumpToIt CLabel -- no args, not a function, but we @@ -662,96 +548,72 @@ data CallingConvention -- zero args to apply to it, so just -- return it. + | ReturnCon DataCon -- It's a data constructor, just return it + | SlowCall -- Unknown fun, or known fun with -- too few args. | DirectEntry -- Jump directly, with args in regs CLabel -- The code label Int -- Its arity - [MagicId] -- Its register assignments - -- (possibly empty) - -getEntryConvention :: Name -- Function being applied - -> LambdaFormInfo -- Its info - -> [PrimRep] -- Available arguments - -> FCode CallingConvention - -getEntryConvention name lf_info arg_kinds - = nodeMustPointToIt lf_info `thenFC` \ node_points -> - returnFC ( - - -- if we're parallel, then we must always enter via node. The reason - -- is that the closure may have been fetched since we allocated it. - - if (node_points && opt_Parallel) then EnterIt else - - -- Commented out by SDM after futher thoughts: - -- - the only closure type that can be blackholed is a thunk - -- - we already enter thunks via node (unless the closure is - -- non-updatable, in which case why is it being re-entered...) - - case lf_info of - - LFReEntrant _ arity _ _ -> - if null arg_kinds then - if arity == 0 then - EnterIt -- a non-updatable thunk - else - ReturnIt -- no args at all - else if listLengthCmp arg_kinds arity == LT then - SlowCall -- not enough args - else - DirectEntry (mkEntryLabel name) arity arg_regs - where - (arg_regs, _) = assignRegs [node] (take arity arg_kinds) - -- we don't use node to pass args now (SDM) - - LFCon con - | isNullaryDataCon con - -- a real constructor. Don't bother entering it, just jump - -- to the constructor entry code directly. - -> --false:ASSERT (null arg_kinds) - -- Should have no args (meaning what?) - JumpToIt (mkStaticConEntryLabel (dataConName con)) - - | otherwise {- not nullary -} - -> --false:ASSERT (null arg_kinds) - -- Should have no args (meaning what?) - JumpToIt (mkConEntryLabel (dataConName con)) - - LFThunk _ _ updatable std_form_info is_fun - -- must always "call" a function-typed thing, cannot just enter it - | is_fun -> SlowCall - | updatable || opt_DoTickyProfiling -- to catch double entry - || opt_SMP -- always enter via node on SMP, since the + +getCallMethod :: Name -- Function being applied + -> LambdaFormInfo -- Its info + -> Int -- Number of available arguments + -> CallMethod + +getCallMethod name lf_info n_args + | nodeMustPointToIt lf_info && opt_Parallel + = -- If we're parallel, then we must always enter via node. + -- The reason is that the closure may have been + -- fetched since we allocated it. + EnterIt + +getCallMethod name (LFReEntrant _ arity _ _) n_args + | n_args == 0 = ASSERT( arity /= 0 ) + ReturnIt -- No args at all + | n_args < arity = SlowCall -- Not enough args + | otherwise = DirectEntry (enterIdLabel name) arity + +getCallMethod name (LFCon con) n_args + = ASSERT( n_args == 0 ) + ReturnCon con + +getCallMethod name (LFThunk _ _ updatable std_form_info is_fun) n_args + | is_fun -- Must always "call" a function-typed + = SlowCall -- thing, cannot just enter it [in eval/apply, the entry code + -- is the fast-entry code] + + | updatable || opt_DoTickyProfiling -- to catch double entry + || opt_SMP -- Always enter via node on SMP, since the -- thunk might have been blackholed in the -- meantime. - -> ASSERT(null arg_kinds) EnterIt - | otherwise - -> ASSERT(null arg_kinds) - JumpToIt (thunkEntryLabel name std_form_info updatable) - - LFUnknown True -> SlowCall -- might be a function - LFUnknown False -> ASSERT2 (null arg_kinds, ppr name <+> ppr arg_kinds) EnterIt -- not a function - - LFBlackHole _ -> SlowCall -- Presumably the black hole has by now - -- been updated, but we don't know with - -- what, so we slow call it - - LFLetNoEscape 0 - -> JumpToIt (mkReturnPtLabel (nameUnique name)) - - LFLetNoEscape arity - -> if (not (arg_kinds `lengthIs` arity)) then pprPanic "let-no-escape: " (ppr name <+> ppr arity) else - DirectEntry (mkReturnPtLabel (nameUnique name)) arity arg_regs - where - (arg_regs, _) = assignRegs [] arg_kinds - -- node never points to a LetNoEscape, see above --SDM - --live_regs = if node_points then [node] else [] - ) + = ASSERT( n_args == 0 ) EnterIt -blackHoleOnEntry :: ClosureInfo -> Bool + | otherwise -- Jump direct to code for single-entry thunks + = ASSERT( n_args == 0 ) + JumpToIt (thunkEntryLabel name std_form_info updatable) + +getCallMethod name (LFUnknown True) n_args + = SlowCall -- might be a function + +getCallMethod name (LFUnknown False) n_args + = ASSERT2 ( n_args == 0, ppr name <+> ppr n_args ) + EnterIt -- Not a function +getCallMethod name (LFBlackHole _) n_args + = SlowCall -- Presumably the black hole has by now + -- been updated, but we don't know with + -- what, so we slow call it + +getCallMethod name (LFLetNoEscape 0) n_args + = JumpToIt (enterReturnPtLabel (nameUnique name)) + +getCallMethod name (LFLetNoEscape arity) n_args + | n_args == arity = DirectEntry (enterReturnPtLabel (nameUnique name)) arity + | otherwise = pprPanic "let-no-escape: " (ppr name <+> ppr arity) + +blackHoleOnEntry :: ClosureInfo -> Bool -- Static closures are never themselves black-holed. -- Updatable ones will be overwritten with a CAFList cell, which points to a -- black hole; @@ -777,11 +639,14 @@ blackHoleOnEntry (ClosureInfo { closureLFInfo = lf_info, closureSMRep = rep }) other -> panic "blackHoleOnEntry" -- Should never happen isStandardFormThunk :: LambdaFormInfo -> Bool - isStandardFormThunk (LFThunk _ _ _ (SelectorThunk _) _) = True isStandardFormThunk (LFThunk _ _ _ (ApThunk _) _) = True isStandardFormThunk other_lf_info = False +isKnownFun :: LambdaFormInfo -> Bool +isKnownFun (LFReEntrant _ _ _ _) = True +isKnownFun (LFLetNoEscape _) = True +isKnownFun _ = False \end{code} ----------------------------------------------------------------------------- @@ -908,10 +773,9 @@ closureReEntrant :: ClosureInfo -> Bool closureReEntrant (ClosureInfo { closureLFInfo = LFReEntrant _ _ _ _ }) = True closureReEntrant other_closure = False -closureSemiTag :: ClosureInfo -> Maybe Int -closureSemiTag (ConInfo { closureCon = data_con }) - = Just (dataConTag data_con - fIRST_TAG) -closureSemiTag _ = Nothing +isConstrClosure_maybe :: ClosureInfo -> Maybe DataCon +isConstrClosure_maybe (ConInfo { closureCon = data_con }) = Just data_con +isConstrClosure_maybe _ = Nothing closureFunInfo :: ClosureInfo -> Maybe (Int, ArgDescr) closureFunInfo (ClosureInfo { closureLFInfo = LFReEntrant _ arity _ arg_desc}) @@ -948,8 +812,7 @@ infoTableLabelFromCI (ClosureInfo { closureName = name, LFThunk{} -> mkInfoTableLabel name - LFReEntrant _ _ _ (ArgGen _ _) -> mkInfoTableLabel name - LFReEntrant _ _ _ _ -> mkInfoTableLabel name + LFReEntrant _ _ _ _ -> mkInfoTableLabel name other -> panic "infoTableLabelFromCI" @@ -964,50 +827,37 @@ mkConInfoPtr con rep where name = dataConName con -mkConEntryPtr :: DataCon -> SMRep -> CLabel -mkConEntryPtr con rep - | isStaticRep rep = mkStaticConEntryLabel (dataConName con) - | otherwise = mkConEntryLabel (dataConName con) - closureLabelFromCI (ClosureInfo { closureName = nm }) = mkClosureLabel nm closureLabelFromCI _ = panic "closureLabelFromCI" -entryLabelFromCI :: ClosureInfo -> CLabel -entryLabelFromCI (ClosureInfo { closureName = id, - closureLFInfo = lf_info, - closureSMRep = rep }) - = case lf_info of - LFThunk _ _ upd_flag std_form_info _ -> - thunkEntryLabel id std_form_info upd_flag - other -> mkEntryLabel id - -entryLabelFromCI (ConInfo { closureCon = con, closureSMRep = rep }) - = mkConEntryPtr con rep - - -- thunkEntryLabel is a local help function, not exported. It's used from both --- entryLabelFromCI and getEntryConvention. +-- entryLabelFromCI and getCallMethod. thunkEntryLabel thunk_id (ApThunk arity) is_updatable - = mkApEntryLabel is_updatable arity + = enterApLabel is_updatable arity thunkEntryLabel thunk_id (SelectorThunk offset) upd_flag - = mkSelectorEntryLabel upd_flag offset + = enterSelectorLabel upd_flag offset thunkEntryLabel thunk_id _ is_updatable - = mkEntryLabel thunk_id -\end{code} + = enterIdLabel thunk_id -\begin{code} -allocProfilingMsg :: ClosureInfo -> FastString -allocProfilingMsg ConInfo{} = FSLIT("TICK_ALLOC_CON") -allocProfilingMsg ClosureInfo{ closureLFInfo = lf_info } - = case lf_info of - LFReEntrant _ _ _ _ -> FSLIT("TICK_ALLOC_FUN") - LFThunk _ _ True _ _ -> FSLIT("TICK_ALLOC_UP_THK") -- updatable - LFThunk _ _ False _ _ -> FSLIT("TICK_ALLOC_SE_THK") -- nonupdatable - LFBlackHole _ -> FSLIT("TICK_ALLOC_BH") - _ -> panic "allocProfilingMsg" +enterApLabel is_updatable arity + | tablesNextToCode = mkApInfoTableLabel is_updatable arity + | otherwise = mkApEntryLabel is_updatable arity + +enterSelectorLabel upd_flag offset + | tablesNextToCode = mkSelectorInfoLabel upd_flag offset + | otherwise = mkSelectorEntryLabel upd_flag offset + +enterIdLabel id + | tablesNextToCode = mkInfoTableLabel id + | otherwise = mkEntryLabel id + +enterReturnPtLabel name + | tablesNextToCode = mkReturnInfoLabel name + | otherwise = mkReturnPtLabel name \end{code} + We need a black-hole closure info to pass to @allocDynClosure@ when we want to allocate the black hole on entry to a CAF. These are the only ways to build an LFBlackHole, maintaining the invariant that it really @@ -1051,7 +901,12 @@ The type is determined from the type information stored with the @Id@ in the closure info using @closureTypeDescr@. \begin{code} -closureTypeDescr :: ClosureInfo -> String +closureValDescr, closureTypeDescr :: ClosureInfo -> String +closureValDescr (ClosureInfo {closureDescr = descr}) + = descr +closureValDescr (ConInfo {closureCon = con}) + = occNameUserString (getOccName con) + closureTypeDescr (ClosureInfo { closureType = ty }) = getTyDescription ty closureTypeDescr (ConInfo { closureCon = data_con }) @@ -1079,268 +934,4 @@ getPredTyDescription (ClassP cl tys) = getOccString cl getPredTyDescription (IParam ip ty) = getOccString (ipNameName ip) \end{code} -%************************************************************************ -%* * -\subsection{Making argument bitmaps} -%* * -%************************************************************************ - -\begin{code} --- bring in ARG_P, ARG_N, etc. -#include "../includes/StgFun.h" - -data ArgDescr - = ArgSpec - !Int -- ARG_P, ARG_N, ... - | ArgGen - CLabel -- label for a slow-entry point - Liveness -- the arg bitmap: describes pointedness of arguments - -mkArgDescr :: Name -> [Id] -> ArgDescr -mkArgDescr nm args = argDescr nm (filter nonVoidRep (map idPrimRep args)) - where nonVoidRep VoidRep = False - nonVoidRep _ = True - -argDescr nm [PtrRep] = ArgSpec ARG_P -argDescr nm [FloatRep] = ArgSpec ARG_F -argDescr nm [DoubleRep] = ArgSpec ARG_D -argDescr nm [r] | is64BitRep r = ArgSpec ARG_L -argDescr nm [r] | isNonPtrRep r = ArgSpec ARG_N - -argDescr nm [r1,r2] | isNonPtrRep r1 && isNonPtrRep r2 = ArgSpec ARG_NN -argDescr nm [r1,PtrRep] | isNonPtrRep r1 = ArgSpec ARG_NP -argDescr nm [PtrRep,r1] | isNonPtrRep r1 = ArgSpec ARG_PN -argDescr nm [PtrRep,PtrRep] = ArgSpec ARG_PP - -argDescr nm [r1,r2,r3] | isNonPtrRep r1 && isNonPtrRep r2 && isNonPtrRep r3 = ArgSpec ARG_NNN -argDescr nm [r1,r2,PtrRep] | isNonPtrRep r1 && isNonPtrRep r2 = ArgSpec ARG_NNP -argDescr nm [r1,PtrRep,r2] | isNonPtrRep r1 && isNonPtrRep r2 = ArgSpec ARG_NPN -argDescr nm [r1,PtrRep,PtrRep] | isNonPtrRep r1 = ArgSpec ARG_NPP -argDescr nm [PtrRep,r1,r2] | isNonPtrRep r1 && isNonPtrRep r2 = ArgSpec ARG_PNN -argDescr nm [PtrRep,r1,PtrRep] | isNonPtrRep r1 = ArgSpec ARG_PNP -argDescr nm [PtrRep,PtrRep,r1] | isNonPtrRep r1 = ArgSpec ARG_PPN -argDescr nm [PtrRep,PtrRep,PtrRep] = ArgSpec ARG_PPP - -argDescr nm [PtrRep,PtrRep,PtrRep,PtrRep] = ArgSpec ARG_PPPP -argDescr nm [PtrRep,PtrRep,PtrRep,PtrRep,PtrRep] = ArgSpec ARG_PPPPP -argDescr nm [PtrRep,PtrRep,PtrRep,PtrRep,PtrRep,PtrRep] = ArgSpec ARG_PPPPPP - -argDescr name reps = ArgGen (mkSlowEntryLabel name) liveness - where bitmap = argBits reps - lbl = mkBitmapLabel name - liveness = Liveness lbl (length bitmap) (mkBitmap bitmap) - -argBits [] = [] -argBits (rep : args) - | isFollowableRep rep = False : argBits args - | otherwise = take (getPrimRepSize rep) (repeat True) ++ argBits args -\end{code} - -%************************************************************************ -%* * -\subsection{Generating info tables} -%* * -%************************************************************************ - -Here we make a concrete info table, represented as a list of CAddrMode -(it can't be simply a list of Word, because the SRT field is -represented by a label+offset expression). - -\begin{code} -mkInfoTable :: ClosureInfo -> [CAddrMode] -mkInfoTable cl_info - | tablesNextToCode = extra_bits ++ std_info - | otherwise = std_info ++ extra_bits - where - std_info = mkStdInfoTable entry_amode - ty_descr_amode cl_descr_amode cl_type srt_len layout_amode - - entry_amode = CLbl (entryLabelFromCI cl_info) CodePtrRep - - closure_descr = - case cl_info of - ClosureInfo { closureDescr = descr } -> descr - ConInfo { closureCon = con } -> occNameUserString (getOccName con) - - ty_descr_amode = CLit (MachStr (mkFastString (closureTypeDescr cl_info))) - cl_descr_amode = CLit (MachStr (mkFastString closure_descr)) - - cl_type = getSMRepClosureTypeInt (closureSMRep cl_info) - - srt = closureSRT cl_info - needs_srt = needsSRT srt - - semi_tag = closureSemiTag cl_info - is_con = isJust semi_tag - - (srt_label,srt_len) - | Just tag <- semi_tag = (mkIntCLit 0, fromIntegral tag) -- constructor - | otherwise = - case srt of - NoC_SRT -> (mkIntCLit 0, 0) - C_SRT lbl off bitmap -> - (CAddr (CIndex (CLbl lbl DataPtrRep) (mkIntCLit off) WordRep), - bitmap) - - ptrs = closurePtrsSize cl_info - nptrs = size - ptrs - size = closureNonHdrSize cl_info - - layout_info :: StgWord -#ifdef WORDS_BIGENDIAN - layout_info = (fromIntegral ptrs `shiftL` hALF_WORD) .|. fromIntegral nptrs -#else - layout_info = (fromIntegral ptrs) .|. (fromIntegral nptrs `shiftL` hALF_WORD) -#endif - - layout_amode = mkWordCLit layout_info - - extra_bits - | is_fun = fun_extra_bits - | is_con = [] - | needs_srt = [srt_label] - | otherwise = [] - - maybe_fun_stuff = closureFunInfo cl_info - is_fun = isJust maybe_fun_stuff - (Just (arity, arg_descr)) = maybe_fun_stuff - - fun_extra_bits - | tablesNextToCode = reg_fun_extra_bits - | otherwise = reverse reg_fun_extra_bits - - reg_fun_extra_bits - | ArgGen slow_lbl liveness <- arg_descr - = [ - CLbl slow_lbl CodePtrRep, - livenessToAddrMode liveness, - srt_label, - fun_amode - ] - | needs_srt = [srt_label, fun_amode] - | otherwise = [fun_amode] - -#ifdef WORDS_BIGENDIAN - fun_desc = (fromIntegral fun_type `shiftL` hALF_WORD) .|. fromIntegral arity -#else - fun_desc = (fromIntegral fun_type) .|. (fromIntegral arity `shiftL` hALF_WORD) -#endif - - fun_amode = mkWordCLit fun_desc - - fun_type = case arg_descr of - ArgSpec n -> n - ArgGen _ (Liveness _ size _) - | size <= mAX_SMALL_BITMAP_SIZE -> ARG_GEN - | otherwise -> ARG_GEN_BIG - --- Return info tables come in two flavours: direct returns and --- vectored returns. - -mkRetInfoTable :: CLabel -> C_SRT -> Liveness -> [CAddrMode] -mkRetInfoTable entry_lbl srt liveness - = mkBitmapInfoTable (CLbl entry_lbl CodePtrRep) srt liveness [] - -mkVecInfoTable :: [CAddrMode] -> C_SRT -> Liveness -> [CAddrMode] -mkVecInfoTable vector srt liveness - = mkBitmapInfoTable zero_amode srt liveness vector - -mkBitmapInfoTable - :: CAddrMode - -> C_SRT -> Liveness - -> [CAddrMode] - -> [CAddrMode] -mkBitmapInfoTable entry_amode srt liveness vector - | tablesNextToCode = extra_bits ++ std_info - | otherwise = std_info ++ extra_bits - where - std_info = mkStdInfoTable entry_amode zero_amode zero_amode - cl_type srt_len liveness_amode - - liveness_amode = livenessToAddrMode liveness - - (srt_label,srt_len) = - case srt of - NoC_SRT -> (mkIntCLit 0, 0) - C_SRT lbl off bitmap -> - (CAddr (CIndex (CLbl lbl DataPtrRep) (mkIntCLit off) WordRep), - bitmap) - - cl_type = case (null vector, isBigLiveness liveness) of - (True, True) -> rET_BIG - (True, False) -> rET_SMALL - (False, True) -> rET_VEC_BIG - (False, False) -> rET_VEC_SMALL - - srt_bit | needsSRT srt || not (null vector) = [srt_label] - | otherwise = [] - - extra_bits | tablesNextToCode = reverse vector ++ srt_bit - | otherwise = srt_bit ++ vector - --- The standard bits of an info table. This part of the info table --- corresponds to the StgInfoTable type defined in InfoTables.h. - -mkStdInfoTable - :: CAddrMode -- entry label - -> CAddrMode -- closure type descr (profiling) - -> CAddrMode -- closure descr (profiling) - -> Int -- closure type - -> StgHalfWord -- SRT length - -> CAddrMode -- layout field - -> [CAddrMode] -mkStdInfoTable entry_lbl type_descr closure_descr cl_type srt_len layout_amode - = std_info - where - std_info - | tablesNextToCode = std_info' - | otherwise = entry_lbl : std_info' - - std_info' = - -- par info - prof_info ++ - -- ticky info - -- debug info - [layout_amode] ++ - CLit (MachWord (fromIntegral type_info)) : - [] - - prof_info - | opt_SccProfilingOn = [ type_descr, closure_descr ] - | otherwise = [] - - -- sigh: building up the info table is endian-dependent. - -- ToDo: do this using .byte and .word directives. - type_info :: StgWord -#ifdef WORDS_BIGENDIAN - type_info = (fromIntegral cl_type `shiftL` hALF_WORD) .|. - (fromIntegral srt_len) -#else - type_info = (fromIntegral cl_type) .|. - (fromIntegral srt_len `shiftL` hALF_WORD) -#endif - -isBigLiveness (Liveness _ size _) = size > mAX_SMALL_BITMAP_SIZE - -livenessToAddrMode :: Liveness -> CAddrMode -livenessToAddrMode (Liveness lbl size bits) - | size <= mAX_SMALL_BITMAP_SIZE = small - | otherwise = CLbl lbl DataPtrRep - where - small = mkWordCLit (fromIntegral size .|. (small_bits `shiftL` bITMAP_BITS_SHIFT)) - small_bits = case bits of - [] -> 0 - [b] -> fromIntegral b - _ -> panic "livenessToAddrMode" - -zero_amode = mkIntCLit 0 - --- IA64 mangler doesn't place tables next to code -tablesNextToCode :: Bool -#ifdef ia64_TARGET_ARCH -tablesNextToCode = False -#else -tablesNextToCode = not opt_Unregisterised -#endif -\end{code} diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs index 1c817aef51..d7f2f70c43 100644 --- a/ghc/compiler/codeGen/CodeGen.lhs +++ b/ghc/compiler/codeGen/CodeGen.lhs @@ -19,39 +19,41 @@ module CodeGen ( codeGen ) where #include "HsVersions.h" +import DriverState ( v_Build_tag, v_MainModIs ) + -- Kludge (??) so that CgExpr is reached via at least one non-SOURCE -- import. Before, that wasn't the case, and CM therefore didn't -- bother to compile it. import CgExpr ( {-NOTHING!-} ) -- DO NOT DELETE THIS IMPORT +import CgProf +import CgMonad +import CgBindery ( CgIdInfo, addBindC, addBindsC, getCgIdInfo, + cgIdInfoId ) +import CgClosure ( cgTopRhsClosure ) +import CgCon ( cgTopRhsCon, cgTyCon ) +import CgUtils ( cmmRegOffW, emitRODataLits, cmmNeWord, emitRtsCall ) + +import CLabel ( mkSRTLabel, mkClosureLabel, moduleRegdLabel, + mkPlainModuleInitLabel, mkModuleInitLabel ) +import Cmm +import CmmUtils ( zeroCLit, mkIntCLit, mkLblExpr ) +import PprCmm ( pprCmms ) +import MachOp ( wordRep, MachHint(..) ) -import DriverState ( v_Build_tag, v_MainModIs ) import StgSyn -import CgMonad -import AbsCSyn import PrelNames ( gHC_PRIM, rOOT_MAIN, mAIN_Name, pREL_TOP_HANDLER ) -import CLabel ( mkSRTLabel, mkClosureLabel, - mkPlainModuleInitLabel, mkModuleInitLabel ) -import PprAbsC ( dumpRealC ) -import AbsCUtils ( mkAbstractCs, flattenAbsC ) -import CgBindery ( CgIdInfo, addBindC, addBindsC, getCAddrModeAndInfo ) -import CgClosure ( cgTopRhsClosure ) -import CgCon ( cgTopRhsCon ) -import CgConTbls ( genStaticConBits ) -import ClosureInfo ( mkClosureLFInfo ) -import CmdLineOpts ( DynFlags, DynFlag(..), - opt_SccProfilingOn, opt_EnsureSplittableC ) +import CmdLineOpts ( DynFlags, DynFlag(..), opt_EnsureSplittableC, + opt_SccProfilingOn ) + import HscTypes ( ForeignStubs(..), TypeEnv, typeEnvTyCons ) import CostCentre ( CollectedCCs ) import Id ( Id, idName, setIdName ) import Name ( nameSrcLoc, nameOccName, nameUnique, isInternalName, mkExternalName ) import OccName ( mkLocalOcc ) -import PrimRep ( PrimRep(..) ) import TyCon ( isDataTyCon ) import Module ( Module, mkModuleName ) -import BasicTypes ( TopLevelFlag(..) ) -import UniqSupply ( mkSplitUniqSupply ) import ErrUtils ( dumpIfSet_dyn, showPass ) -import Panic ( assertPanic ) +import Panic ( assertPanic, trace ) import qualified Module ( moduleName ) #ifdef DEBUG @@ -69,44 +71,37 @@ codeGen :: DynFlags -> [Module] -- directly-imported modules -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering. -> [(StgBinding,[(Id,[Id])])] -- Bindings to convert, with SRTs - -> IO AbstractC -- Output + -> IO [Cmm] -- Output codeGen dflags this_mod type_env foreign_stubs imported_mods cost_centre_info stg_binds = do - showPass dflags "CodeGen" - fl_uniqs <- mkSplitUniqSupply 'f' - way <- readIORef v_Build_tag - mb_main_mod <- readIORef v_MainModIs - - let - tycons = typeEnvTyCons type_env - data_tycons = filter isDataTyCon tycons - - mapM_ (\x -> seq x (return ())) data_tycons - - let - - cinfo = MkCompInfo this_mod - - datatype_stuff = genStaticConBits cinfo data_tycons - code_stuff = initC cinfo (mapCs cgTopBinding stg_binds) - init_stuff = mkModuleInit way cost_centre_info - this_mod mb_main_mod - foreign_stubs imported_mods - - abstractC = mkAbstractCs [ maybeSplitCode, - init_stuff, - code_stuff, - datatype_stuff] + { showPass dflags "CodeGen" + ; way <- readIORef v_Build_tag + ; mb_main_mod <- readIORef v_MainModIs + + ; let tycons = typeEnvTyCons type_env + data_tycons = filter isDataTyCon tycons + +-- Why? +-- ; mapM_ (\x -> seq x (return ())) data_tycons + + ; code_stuff <- initC this_mod $ do + { cmm_binds <- mapM (getCmm . cgTopBinding) stg_binds + ; cmm_tycons <- mapM cgTyCon data_tycons + ; cmm_init <- getCmm (mkModuleInit way cost_centre_info + this_mod mb_main_mod + foreign_stubs imported_mods) + ; return (cmm_binds ++ concat cmm_tycons ++ [cmm_init]) + } -- Put datatype_stuff after code_stuff, because the -- datatype closure table (for enumeration types) to -- (say) PrelBase_True_closure, which is defined in -- code_stuff - dumpIfSet_dyn dflags Opt_D_dump_absC "Abstract C" (dumpRealC abstractC) + ; dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms code_stuff) - return $! flattenAbsC fl_uniqs abstractC + ; return code_stuff } \end{code} %************************************************************************ @@ -115,6 +110,43 @@ codeGen dflags this_mod type_env foreign_stubs imported_mods %* * %************************************************************************ +/* ----------------------------------------------------------------------------- + Module initialisation + + The module initialisation code looks like this, roughly: + + FN(__stginit_Foo) { + JMP_(__stginit_Foo_1_p) + } + + FN(__stginit_Foo_1_p) { + ... + } + + We have one version of the init code with a module version and the + 'way' attached to it. The version number helps to catch cases + where modules are not compiled in dependency order before being + linked: if a module has been compiled since any modules which depend on + it, then the latter modules will refer to a different version in their + init blocks and a link error will ensue. + + The 'way' suffix helps to catch cases where modules compiled in different + ways are linked together (eg. profiled and non-profiled). + + We provide a plain, unadorned, version of the module init code + which just jumps to the version with the label and way attached. The + reason for this is that when using foreign exports, the caller of + startupHaskell() must supply the name of the init function for the "top" + module in the program, and we don't want to require that this name + has the version and way info appended to it. + -------------------------------------------------------------------------- */ + +We initialise the module tree by keeping a work-stack, + * pointed to by Sp + * that grows downward + * Sp points to the last occupied slot + + \begin{code} mkModuleInit :: String -- the "way" @@ -123,61 +155,95 @@ mkModuleInit -> Maybe String -- Just m ==> we have flag: -main-is Foo.baz -> ForeignStubs -> [Module] - -> AbstractC + -> Code mkModuleInit way cost_centre_info this_mod mb_main_mod foreign_stubs imported_mods - = let - (cc_decls, cc_regs) = mkCostCentreStuff cost_centre_info + = do { - register_foreign_exports - = case foreign_stubs of - NoStubs -> [] - ForeignStubs _ _ _ fe_bndrs -> map mk_export_register fe_bndrs + -- Allocate the static boolean that records if this + -- module has been registered already + ; emitData Data [CmmDataLabel moduleRegdLabel, + CmmStaticLit zeroCLit] - mk_export_register bndr - = CMacroStmt REGISTER_FOREIGN_EXPORT [lbl] - where - lbl = CLbl (mkClosureLabel (idName bndr)) PtrRep - -- we don't want/need to init GHC.Prim, so filter it out + ; emitSimpleProc real_init_lbl $ do + { -- The return-code pops the work stack by + -- incrementing Sp, and then jumpd to the popped item + ret_blk <- forkLabelledCode $ stmtsC + [ CmmAssign spReg (cmmRegOffW spReg 1) + , CmmJump (CmmLoad (cmmRegOffW spReg (-1)) wordRep) [] ] - mk_import_register mod - | mod == gHC_PRIM = AbsCNop - | otherwise = CMacroStmt REGISTER_IMPORT [ - CLbl (mkModuleInitLabel mod way) AddrRep - ] + ; init_blk <- forkLabelledCode $ do + { mod_init_code; stmtC (CmmBranch ret_blk) } + + ; stmtC (CmmCondBranch (cmmNeWord (CmmLit zeroCLit) mod_reg_val) + ret_blk) + ; stmtC (CmmBranch init_blk) + } - extra_imported_mods - | Module.moduleName this_mod == main_mod_name = [ pREL_TOP_HANDLER ] - | otherwise = [ ] - register_mod_imports = - map mk_import_register (imported_mods ++ extra_imported_mods) + -- Make the "plain" procedure jump to the "real" init procedure + ; emitSimpleProc plain_init_lbl jump_to_init -- When compiling the module in which the 'main' function lives, + -- (that is, Module.moduleName this_mod == main_mod_name) -- we inject an extra stg_init procedure for stg_init_ZCMain, for the -- RTS to invoke. We must consult the -main-is flag in case the -- user specified a different function to Main.main - main_mod_name = case mb_main_mod of - Just mod_name -> mkModuleName mod_name - Nothing -> mAIN_Name - main_init_block - | Module.moduleName this_mod /= main_mod_name - = AbsCNop -- The normal case - | otherwise -- this_mod contains the main function - = CCodeBlock (mkPlainModuleInitLabel rOOT_MAIN) - (CJump (CLbl (mkPlainModuleInitLabel this_mod) CodePtrRep)) - - in - mkAbstractCs [ - cc_decls, - CModuleInitBlock (mkPlainModuleInitLabel this_mod) - (mkModuleInitLabel this_mod way) - (mkAbstractCs (register_foreign_exports ++ - cc_regs : - register_mod_imports)), - main_init_block - ] + ; whenC (Module.moduleName this_mod == main_mod_name) + (emitSimpleProc plain_main_init_lbl jump_to_init) + } + where + plain_init_lbl = mkPlainModuleInitLabel this_mod + real_init_lbl = mkModuleInitLabel this_mod way + plain_main_init_lbl = mkPlainModuleInitLabel rOOT_MAIN + + jump_to_init = stmtC (CmmJump (mkLblExpr real_init_lbl) []) + + mod_reg_val = CmmLoad (mkLblExpr moduleRegdLabel) wordRep + + main_mod_name = case mb_main_mod of + Just mod_name -> mkModuleName mod_name + Nothing -> mAIN_Name + + -- Main refers to GHC.TopHandler.runIO, so make sure we call the + -- init function for GHC.TopHandler. + extra_imported_mods + | Module.moduleName this_mod == main_mod_name = [pREL_TOP_HANDLER] + | otherwise = [] + + mod_init_code = do + { -- Set mod_reg to 1 to record that we've been here + stmtC (CmmStore (mkLblExpr moduleRegdLabel) (CmmLit (mkIntCLit 1))) + + -- Now do local stuff + ; registerForeignExports foreign_stubs + ; initCostCentres cost_centre_info + ; mapCs (registerModuleImport way) (imported_mods++extra_imported_mods) + } + + +----------------------- +registerModuleImport :: String -> Module -> Code +registerModuleImport way mod + | mod == gHC_PRIM + = nopC + | otherwise -- Push the init procedure onto the work stack + = stmtsC [ CmmAssign spReg (cmmRegOffW spReg (-1)) + , CmmStore (CmmReg spReg) (mkLblExpr (mkModuleInitLabel mod way)) ] + +----------------------- +registerForeignExports :: ForeignStubs -> Code +registerForeignExports NoStubs + = nopC +registerForeignExports (ForeignStubs _ _ _ fe_bndrs) + = mapM_ mk_export_register fe_bndrs + where + mk_export_register bndr + = emitRtsCall SLIT("getStablePtr") + [ (CmmLit (CmmLabel (mkClosureLabel (idName bndr))), PtrHint) ] \end{code} + + Cost-centre profiling: Besides the usual stuff, we must produce declarations for the cost-centres defined in this module; @@ -185,28 +251,16 @@ declarations for the cost-centres defined in this module; code-generator.) \begin{code} -mkCostCentreStuff (local_CCs, extern_CCs, singleton_CCSs) - | not opt_SccProfilingOn = (AbsCNop, AbsCNop) - | otherwise = - ( mkAbstractCs ( - map (CCostCentreDecl True) local_CCs ++ - map (CCostCentreDecl False) extern_CCs ++ - map CCostCentreStackDecl singleton_CCSs), - mkAbstractCs (mkCcRegister local_CCs singleton_CCSs) - ) - where - mkCcRegister ccs cc_stacks - = let - register_ccs = mkAbstractCs (map mk_register ccs) - register_cc_stacks = mkAbstractCs (map mk_register_ccs cc_stacks) - in - [ register_ccs, register_cc_stacks ] - where - mk_register cc - = CCallProfCCMacro FSLIT("REGISTER_CC") [mkCCostCentre cc] - - mk_register_ccs ccs - = CCallProfCCMacro FSLIT("REGISTER_CCS") [mkCCostCentreStack ccs] +initCostCentres :: CollectedCCs -> Code +-- Emit the declarations, and return code to register them +initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs) + | not opt_SccProfilingOn = nopC + | otherwise + = do { mapM_ emitCostCentreDecl local_CCs + ; mapM_ emitCostCentreStackDecl singleton_CCSs + ; mapM_ emitRegisterCC local_CCs + ; mapM_ emitRegisterCCS singleton_CCSs + } \end{code} %************************************************************************ @@ -228,44 +282,37 @@ variable. \begin{code} cgTopBinding :: (StgBinding,[(Id,[Id])]) -> Code cgTopBinding (StgNonRec id rhs, srts) - = absC maybeSplitCode `thenC` - maybeExternaliseId id `thenFC` \ id' -> - mapM_ (mkSRT [id']) srts `thenC` - cgTopRhs id' rhs `thenFC` \ (id, info) -> - addBindC id info `thenC` - -- Add the un-externalised Id to the envt, so we - -- find it when we look up occurrences - nopC + = do { id' <- maybeExternaliseId id + ; mapM_ (mkSRT [id']) srts + ; (id,info) <- cgTopRhs id' rhs + ; addBindC id info -- Add the *un-externalised* Id to the envt, + -- so we find it when we look up occurrences + } cgTopBinding (StgRec pairs, srts) - = absC maybeSplitCode `thenC` - let - (bndrs, rhss) = unzip pairs - in - mapFCs maybeExternaliseId bndrs `thenFC` \ bndrs' -> - let - pairs' = zip bndrs' rhss - in - mapM_ (mkSRT bndrs') srts `thenC` - fixC (\ new_binds -> - addBindsC new_binds `thenC` - mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs' - ) `thenFC` \ new_binds -> - nopC + = do { let (bndrs, rhss) = unzip pairs + ; bndrs' <- mapFCs maybeExternaliseId bndrs + ; let pairs' = zip bndrs' rhss + ; mapM_ (mkSRT bndrs') srts + ; new_binds <- fixC (\ new_binds -> do + { addBindsC new_binds + ; mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs' }) + ; nopC } mkSRT :: [Id] -> (Id,[Id]) -> Code mkSRT these (id,[]) = nopC mkSRT these (id,ids) - = mapFCs remap ids `thenFC` \ ids -> - remap id `thenFC` \ id -> - absC (CSRT (mkSRTLabel (idName id)) (map (mkClosureLabel . idName) ids)) + = do { ids <- mapFCs remap ids + ; id <- remap id + ; emitRODataLits (mkSRTLabel (idName id)) + (map (CmmLabel . mkClosureLabel . idName) ids) + } where - -- sigh, better map all the ids against the environment in case they've - -- been externalised (see maybeExternaliseId below). + -- Sigh, better map all the ids against the environment in + -- case they've been externalised (see maybeExternaliseId below). remap id = case filter (==id) these of - [] -> getCAddrModeAndInfo id - `thenFC` \ (id, _, _) -> returnFC id (id':_) -> returnFC id' + [] -> do { info <- getCgIdInfo id; return (cgIdInfoId info) } -- Urgh! I tried moving the forkStatics call from the rhss of cgTopRhs -- to enclose the listFCs in cgTopBinding, but that tickled the @@ -280,12 +327,8 @@ cgTopRhs bndr (StgRhsCon cc con args) cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag srt args body) = ASSERT(null fvs) -- There should be no free variables - let - srt_label = mkSRTLabel (idName bndr) - lf_info = mkClosureLFInfo bndr TopLevel [{-no fvs-}] upd_flag args - in - setSRTLabel srt_label $ - forkStatics (cgTopRhsClosure bndr cc bi srt args body lf_info) + setSRTLabel (mkSRTLabel (idName bndr)) $ + forkStatics (cgTopRhsClosure bndr cc bi srt upd_flag args body) \end{code} @@ -303,21 +346,17 @@ which refers to this name). maybeExternaliseId :: Id -> FCode Id maybeExternaliseId id | opt_EnsureSplittableC, -- Externalise the name for -split-objs - isInternalName name - = moduleName `thenFC` \ mod -> - returnFC (setIdName id (mkExternalName uniq mod new_occ Nothing (nameSrcLoc name))) - | otherwise - = returnFC id + isInternalName name = do { mod <- moduleName + ; returnFC (setIdName id (externalise mod)) } + | otherwise = returnFC id where - name = idName id - uniq = nameUnique name - new_occ = mkLocalOcc uniq (nameOccName name) + externalise mod = mkExternalName uniq mod new_occ Nothing loc + name = idName id + uniq = nameUnique name + new_occ = mkLocalOcc uniq (nameOccName name) + loc = nameSrcLoc name -- We want to conjure up a name that can't clash with any -- existing name. So we generate -- Mod_$L243foo -- where 243 is the unique. - -maybeSplitCode - | opt_EnsureSplittableC = CSplitMarker - | otherwise = AbsCNop \end{code} diff --git a/ghc/compiler/codeGen/SMRep.lhs b/ghc/compiler/codeGen/SMRep.lhs index 4f53f4bfee..92b9513d56 100644 --- a/ghc/compiler/codeGen/SMRep.lhs +++ b/ghc/compiler/codeGen/SMRep.lhs @@ -8,27 +8,236 @@ Other modules should access this info through ClosureInfo. \begin{code} module SMRep ( + -- Words and bytes + StgWord, StgHalfWord, + hALF_WORD_SIZE, hALF_WORD_SIZE_IN_BITS, + WordOff, ByteOff, + + -- Argument/return representations + CgRep(..), nonVoidArg, + argMachRep, primRepToCgRep, primRepHint, + isFollowableArg, isVoidArg, + isFloatingArg, isNonPtrArg, is64BitArg, + separateByPtrFollowness, + cgRepSizeW, cgRepSizeB, + retAddrSizeW, + + typeCgRep, idCgRep, tyConCgRep, typeHint, + + -- Closure repesentation SMRep(..), ClosureType(..), isStaticRep, fixedHdrSize, arrWordsHdrSize, arrPtrsHdrSize, - stdItblSize, retItblSize, - getSMRepClosureTypeInt, + profHdrSize, + tablesNextToCode, + smRepClosureType, smRepClosureTypeInt, - rET_SMALL, rET_VEC_SMALL, rET_BIG, rET_VEC_BIG, - - StgWord, StgHalfWord, hALF_WORD, + rET_SMALL, rET_VEC_SMALL, rET_BIG, rET_VEC_BIG ) where #include "HsVersions.h" #include "../includes/MachDeps.h" -import CmdLineOpts +import Id ( Id, idType ) +import Type ( Type, typePrimRep, PrimRep(..) ) +import TyCon ( TyCon, tyConPrimRep ) +import MachOp ( MachRep(..), MachHint(..), wordRep ) +import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros, opt_Unregisterised ) import Constants import Outputable import DATA_WORD \end{code} + +%************************************************************************ +%* * + Words and bytes +%* * +%************************************************************************ + +\begin{code} +type WordOff = Int -- Word offset, or word count +type ByteOff = Int -- Byte offset, or byte count +\end{code} + +StgWord is a type representing an StgWord on the target platform. + +\begin{code} +#if SIZEOF_HSWORD == 4 +type StgWord = Word32 +type StgHalfWord = Word16 +hALF_WORD_SIZE = 2 :: ByteOff +hALF_WORD_SIZE_IN_BITS = 16 :: Int +#elif SIZEOF_HSWORD == 8 +type StgWord = Word64 +type StgHalfWord = Word32 +hALF_WORD_SIZE = 4 :: ByteOff +hALF_WORD_SIZE_IN_BITS = 32 :: Int +#else +#error unknown SIZEOF_HSWORD +#endif +\end{code} + + +%************************************************************************ +%* * + CgRep +%* * +%************************************************************************ + +An CgRep is an abstraction of a Type which tells the code generator +all it needs to know about the calling convention for arguments (and +results) of that type. In particular, the ArgReps of a function's +arguments are used to decide which of the RTS's generic apply +functions to call when applying an unknown function. + +It contains more information than the back-end data type MachRep, +so one can easily convert from CgRep -> MachRep. (Except that +there's no MachRep for a VoidRep.) + +It distinguishes + pointers from non-pointers (we sort the pointers together + when building closures) + + void from other types: a void argument is different from no argument + +All 64-bit types map to the same CgRep, because they're passed in the +same register, but a PtrArg is still different from an NonPtrArg +because the function's entry convention has to take into account the +pointer-hood of arguments for the purposes of describing the stack on +entry to the garbage collector. + +\begin{code} +data CgRep + = VoidArg -- Void + | PtrArg -- Word-sized Ptr + | NonPtrArg -- Word-sized non-pointer + | LongArg -- 64-bit non-pointer + | FloatArg -- 32-bit float + | DoubleArg -- 64-bit float + deriving Eq + +instance Outputable CgRep where + ppr VoidArg = ptext SLIT("V_") + ppr PtrArg = ptext SLIT("P_") + ppr NonPtrArg = ptext SLIT("I_") + ppr LongArg = ptext SLIT("L_") + ppr FloatArg = ptext SLIT("F_") + ppr DoubleArg = ptext SLIT("D_") + +argMachRep :: CgRep -> MachRep +argMachRep PtrArg = wordRep +argMachRep NonPtrArg = wordRep +argMachRep LongArg = I64 +argMachRep FloatArg = F32 +argMachRep DoubleArg = F64 +argMachRep VoidArg = panic "argMachRep:VoidRep" + +primRepToCgRep :: PrimRep -> CgRep +primRepToCgRep VoidRep = VoidArg +primRepToCgRep PtrRep = PtrArg +primRepToCgRep IntRep = NonPtrArg +primRepToCgRep WordRep = NonPtrArg +primRepToCgRep Int64Rep = LongArg +primRepToCgRep Word64Rep = LongArg +primRepToCgRep AddrRep = NonPtrArg +primRepToCgRep FloatRep = FloatArg +primRepToCgRep DoubleRep = DoubleArg + +primRepHint :: PrimRep -> MachHint +primRepHint VoidRep = panic "primRepHint:VoidRep" +primRepHint PtrRep = PtrHint +primRepHint IntRep = SignedHint +primRepHint WordRep = NoHint +primRepHint Int64Rep = SignedHint +primRepHint Word64Rep = NoHint +primRepHint AddrRep = PtrHint -- NB! PtrHint, but NonPtrArg +primRepHint FloatRep = FloatHint +primRepHint DoubleRep = FloatHint + +idCgRep :: Id -> CgRep +idCgRep = typeCgRep . idType + +tyConCgRep :: TyCon -> CgRep +tyConCgRep = primRepToCgRep . tyConPrimRep + +typeCgRep :: Type -> CgRep +typeCgRep = primRepToCgRep . typePrimRep + +typeHint :: Type -> MachHint +typeHint = primRepHint . typePrimRep +\end{code} + +Whether or not the thing is a pointer that the garbage-collector +should follow. Or, to put it another (less confusing) way, whether +the object in question is a heap object. + +Depending on the outcome, this predicate determines what stack +the pointer/object possibly will have to be saved onto, and the +computation of GC liveness info. + +\begin{code} +isFollowableArg :: CgRep -> Bool -- True <=> points to a heap object +isFollowableArg PtrArg = True +isFollowableArg other = False + +isVoidArg :: CgRep -> Bool +isVoidArg VoidArg = True +isVoidArg other = False + +nonVoidArg :: CgRep -> Bool +nonVoidArg VoidArg = False +nonVoidArg other = True + +-- isFloatingArg is used to distinguish @Double@ and @Float@ which +-- cause inadvertent numeric conversions if you aren't jolly careful. +-- See codeGen/CgCon:cgTopRhsCon. + +isFloatingArg :: CgRep -> Bool +isFloatingArg DoubleArg = True +isFloatingArg FloatArg = True +isFloatingArg _ = False + +isNonPtrArg :: CgRep -> Bool +-- Identify anything which is one word large and not a pointer. +isNonPtrArg NonPtrArg = True +isNonPtrArg other = False + +is64BitArg :: CgRep -> Bool +is64BitArg LongArg = True +is64BitArg _ = False +\end{code} + +\begin{code} +separateByPtrFollowness :: [(CgRep,a)] -> ([(CgRep,a)], [(CgRep,a)]) +-- Returns (ptrs, non-ptrs) +separateByPtrFollowness things + = sep_things things [] [] + -- accumulating params for follow-able and don't-follow things... + where + sep_things [] bs us = (reverse bs, reverse us) + sep_things ((PtrArg,a):ts) bs us = sep_things ts ((PtrArg,a):bs) us + sep_things (t :ts) bs us = sep_things ts bs (t:us) +\end{code} + +\begin{code} +cgRepSizeB :: CgRep -> ByteOff +cgRepSizeB DoubleArg = dOUBLE_SIZE +cgRepSizeB LongArg = wORD64_SIZE +cgRepSizeB VoidArg = 0 +cgRepSizeB _ = wORD_SIZE + +cgRepSizeW :: CgRep -> ByteOff +cgRepSizeW DoubleArg = dOUBLE_SIZE `quot` wORD_SIZE +cgRepSizeW LongArg = wORD64_SIZE `quot` wORD_SIZE +cgRepSizeW VoidArg = 0 +cgRepSizeW _ = 1 + +retAddrSizeW :: WordOff +retAddrSizeW = 1 -- One word +\end{code} + %************************************************************************ %* * \subsubsection[SMRep-datatype]{@SMRep@---storage manager representation} @@ -59,44 +268,32 @@ data ClosureType -- Corresponds 1-1 with the varieties of closures Size of a closure header. \begin{code} -fixedHdrSize :: Int{-words-} +fixedHdrSize :: WordOff fixedHdrSize = sTD_HDR_SIZE + profHdrSize + granHdrSize -profHdrSize :: Int{-words-} +profHdrSize :: WordOff profHdrSize | opt_SccProfilingOn = pROF_HDR_SIZE | otherwise = 0 -granHdrSize :: Int{-words-} +granHdrSize :: WordOff granHdrSize | opt_GranMacros = gRAN_HDR_SIZE | otherwise = 0 -arrWordsHdrSize :: Int{-words-} -arrWordsHdrSize = fixedHdrSize + aRR_WORDS_HDR_SIZE +arrWordsHdrSize :: ByteOff +arrWordsHdrSize = fixedHdrSize*wORD_SIZE + sIZEOF_StgArrWords_NoHdr -arrPtrsHdrSize :: Int{-words-} -arrPtrsHdrSize = fixedHdrSize + aRR_PTRS_HDR_SIZE +arrPtrsHdrSize :: ByteOff +arrPtrsHdrSize = fixedHdrSize*wORD_SIZE + sIZEOF_StgMutArrPtrs_NoHdr \end{code} -Size of an info table. - \begin{code} -stdItblSize :: Int{-words-} -stdItblSize = sTD_ITBL_SIZE + profItblSize + granItblSize + tickyItblSize - -retItblSize :: Int{-words-} -retItblSize = stdItblSize + rET_ITBL_SIZE - -profItblSize :: Int{-words-} -profItblSize | opt_SccProfilingOn = pROF_ITBL_SIZE - | otherwise = 0 - -granItblSize :: Int{-words-} -granItblSize | opt_GranMacros = gRAN_ITBL_SIZE - | otherwise = 0 - -tickyItblSize :: Int{-words-} -tickyItblSize | opt_DoTickyProfiling = tICKY_ITBL_SIZE - | otherwise = 0 +-- IA64 mangler doesn't place tables next to code +tablesNextToCode :: Bool +#ifdef ia64_TARGET_ARCH +tablesNextToCode = False +#else +tablesNextToCode = not opt_Unregisterised +#endif \end{code} \begin{code} @@ -109,38 +306,43 @@ isStaticRep BlackHoleRep = False #include "../includes/ClosureTypes.h" -- Defines CONSTR, CONSTR_1_0 etc -getSMRepClosureTypeInt :: SMRep -> Int -getSMRepClosureTypeInt (GenericRep False 1 0 Constr) = CONSTR_1_0 -getSMRepClosureTypeInt (GenericRep False 0 1 Constr) = CONSTR_0_1 -getSMRepClosureTypeInt (GenericRep False 2 0 Constr) = CONSTR_2_0 -getSMRepClosureTypeInt (GenericRep False 1 1 Constr) = CONSTR_1_1 -getSMRepClosureTypeInt (GenericRep False 0 2 Constr) = CONSTR_0_2 -getSMRepClosureTypeInt (GenericRep False _ _ Constr) = CONSTR -getSMRepClosureTypeInt (GenericRep False 1 0 Fun) = FUN_1_0 -getSMRepClosureTypeInt (GenericRep False 0 1 Fun) = FUN_0_1 -getSMRepClosureTypeInt (GenericRep False 2 0 Fun) = FUN_2_0 -getSMRepClosureTypeInt (GenericRep False 1 1 Fun) = FUN_1_1 -getSMRepClosureTypeInt (GenericRep False 0 2 Fun) = FUN_0_2 -getSMRepClosureTypeInt (GenericRep False _ _ Fun) = FUN +smRepClosureType :: SMRep -> ClosureType +smRepClosureType (GenericRep _ _ _ ty) = ty +smRepClosureType BlackHoleRep = panic "smRepClosureType: black hole" + +smRepClosureTypeInt :: SMRep -> Int +smRepClosureTypeInt (GenericRep False 1 0 Constr) = CONSTR_1_0 +smRepClosureTypeInt (GenericRep False 0 1 Constr) = CONSTR_0_1 +smRepClosureTypeInt (GenericRep False 2 0 Constr) = CONSTR_2_0 +smRepClosureTypeInt (GenericRep False 1 1 Constr) = CONSTR_1_1 +smRepClosureTypeInt (GenericRep False 0 2 Constr) = CONSTR_0_2 +smRepClosureTypeInt (GenericRep False _ _ Constr) = CONSTR + +smRepClosureTypeInt (GenericRep False 1 0 Fun) = FUN_1_0 +smRepClosureTypeInt (GenericRep False 0 1 Fun) = FUN_0_1 +smRepClosureTypeInt (GenericRep False 2 0 Fun) = FUN_2_0 +smRepClosureTypeInt (GenericRep False 1 1 Fun) = FUN_1_1 +smRepClosureTypeInt (GenericRep False 0 2 Fun) = FUN_0_2 +smRepClosureTypeInt (GenericRep False _ _ Fun) = FUN -getSMRepClosureTypeInt (GenericRep False 1 0 Thunk) = THUNK_1_0 -getSMRepClosureTypeInt (GenericRep False 0 1 Thunk) = THUNK_0_1 -getSMRepClosureTypeInt (GenericRep False 2 0 Thunk) = THUNK_2_0 -getSMRepClosureTypeInt (GenericRep False 1 1 Thunk) = THUNK_1_1 -getSMRepClosureTypeInt (GenericRep False 0 2 Thunk) = THUNK_0_2 -getSMRepClosureTypeInt (GenericRep False _ _ Thunk) = THUNK +smRepClosureTypeInt (GenericRep False 1 0 Thunk) = THUNK_1_0 +smRepClosureTypeInt (GenericRep False 0 1 Thunk) = THUNK_0_1 +smRepClosureTypeInt (GenericRep False 2 0 Thunk) = THUNK_2_0 +smRepClosureTypeInt (GenericRep False 1 1 Thunk) = THUNK_1_1 +smRepClosureTypeInt (GenericRep False 0 2 Thunk) = THUNK_0_2 +smRepClosureTypeInt (GenericRep False _ _ Thunk) = THUNK -getSMRepClosureTypeInt (GenericRep False _ _ ThunkSelector) = THUNK_SELECTOR +smRepClosureTypeInt (GenericRep False _ _ ThunkSelector) = THUNK_SELECTOR -getSMRepClosureTypeInt (GenericRep True _ _ Constr) = CONSTR_STATIC -getSMRepClosureTypeInt (GenericRep True _ _ ConstrNoCaf) = CONSTR_NOCAF_STATIC -getSMRepClosureTypeInt (GenericRep True _ _ Fun) = FUN_STATIC -getSMRepClosureTypeInt (GenericRep True _ _ Thunk) = THUNK_STATIC +smRepClosureTypeInt (GenericRep True _ _ Constr) = CONSTR_STATIC +smRepClosureTypeInt (GenericRep True _ _ ConstrNoCaf) = CONSTR_NOCAF_STATIC +smRepClosureTypeInt (GenericRep True _ _ Fun) = FUN_STATIC +smRepClosureTypeInt (GenericRep True _ _ Thunk) = THUNK_STATIC -getSMRepClosureTypeInt BlackHoleRep = BLACKHOLE +smRepClosureTypeInt BlackHoleRep = BLACKHOLE -getSMRepClosureTypeInt rep = panic "getSMRepClosureTypeInt" +smRepClosureTypeInt rep = panic "smRepClosuretypeint" -- We export these ones @@ -150,18 +352,3 @@ rET_BIG = (RET_BIG :: Int) rET_VEC_BIG = (RET_VEC_BIG :: Int) \end{code} -A type representing an StgWord on the target platform. - -\begin{code} -#if SIZEOF_HSWORD == 4 -type StgWord = Word32 -type StgHalfWord = Word16 -hALF_WORD = 16 :: Int -#elif SIZEOF_HSWORD == 8 -type StgWord = Word64 -type StgHalfWord = Word32 -hALF_WORD = 32 :: Int -#else -#error unknown SIZEOF_HSWORD -#endif -\end{code} diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs index e645cf265a..ce6302afb0 100644 --- a/ghc/compiler/compMan/CompManager.lhs +++ b/ghc/compiler/compMan/CompManager.lhs @@ -4,7 +4,6 @@ % The Compilation Manager % \begin{code} -{-# OPTIONS -fvia-C #-} module CompManager ( ModuleGraph, ModSummary(..), diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs index f30993cadc..57bace2000 100644 --- a/ghc/compiler/deSugar/DsCCall.lhs +++ b/ghc/compiler/deSugar/DsCCall.lhs @@ -23,7 +23,8 @@ import CoreUtils ( exprType, mkCoerce2 ) import Id ( Id, mkWildId ) import MkId ( mkFCallId, realWorldPrimId, mkPrimOpId ) import Maybes ( maybeToBool ) -import ForeignCall ( ForeignCall(..), CCallSpec(..), CCallTarget(..), Safety, CCallConv(..) ) +import ForeignCall ( ForeignCall(..), CCallSpec(..), CCallTarget(..), Safety, + CCallConv(..), CLabelString ) import DataCon ( splitProductType_maybe, dataConSourceArity, dataConWrapId ) import ForeignCall ( ForeignCall, CCallTarget(..) ) @@ -51,7 +52,6 @@ import TysWiredIn ( unitDataConId, ) import BasicTypes ( Boxity(..) ) import Literal ( mkMachInt ) -import CStrings ( CLabelString ) import PrelNames ( Unique, hasKey, ioTyConKey, boolTyConKey, unitTyConKey, int8TyConKey, int16TyConKey, int32TyConKey, word8TyConKey, word16TyConKey, word32TyConKey diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs index 05dcb05221..269274ce5a 100644 --- a/ghc/compiler/deSugar/DsForeign.lhs +++ b/ghc/compiler/deSugar/DsForeign.lhs @@ -18,6 +18,8 @@ import DsMonad import HsSyn ( ForeignDecl(..), ForeignExport(..), LForeignDecl, ForeignImport(..), CImportSpec(..) ) +import MachOp ( machRepByteWidth ) +import SMRep ( argMachRep, primRepToCgRep ) import CoreUtils ( exprType, mkInlineMe ) import Id ( Id, idType, idName, mkSysLocal, setInlinePragma ) import Literal ( Literal(..) ) @@ -34,14 +36,12 @@ import BasicTypes ( Boxity(..) ) import HscTypes ( ForeignStubs(..) ) import ForeignCall ( ForeignCall(..), CCallSpec(..), Safety(..), playSafe, - CExportSpec(..), + CExportSpec(..), CLabelString, CCallConv(..), ccallConvToInt, ccallConvAttribute ) -import CStrings ( CLabelString ) import TysWiredIn ( unitTy, tupleTyCon ) import TysPrim ( addrPrimTy, mkStablePtrPrimTy, alphaTy ) -import PrimRep ( getPrimRepSizeInBytes ) import PrelNames ( hasKey, ioTyConKey, stablePtrTyConName, newStablePtrName, bindIOName, checkDotnetResName ) import BasicTypes ( Activation( NeverActive ) ) @@ -389,7 +389,7 @@ dsFExportDynamic id cconv -- (probably in the RTS.) adjustor = FSLIT("createAdjustor") - sz_args = sum (map (getPrimRepSizeInBytes . typePrimRep) stub_args) + sz_args = sum (map (machRepByteWidth.argMachRep.primRepToCgRep.typePrimRep) stub_args) mb_sz_args = case cconv of StdCallConv -> Just sz_args _ -> Nothing diff --git a/ghc/compiler/ghci/ByteCodeAsm.lhs b/ghc/compiler/ghci/ByteCodeAsm.lhs index 53340e78cd..3958753b69 100644 --- a/ghc/compiler/ghci/ByteCodeAsm.lhs +++ b/ghc/compiler/ghci/ByteCodeAsm.lhs @@ -26,10 +26,9 @@ import FiniteMap ( addToFM, lookupFM, emptyFM ) import Literal ( Literal(..) ) import TyCon ( TyCon ) import PrimOp ( PrimOp ) -import PrimRep ( PrimRep(..), isFollowableRep, is64BitRep ) import Constants ( wORD_SIZE ) import FastString ( FastString(..) ) -import SMRep ( StgWord ) +import SMRep ( CgRep(..), StgWord ) import FiniteMap import Outputable @@ -356,27 +355,19 @@ mkBits findLabel st proto_insns literal st other = pprPanic "ByteCodeLink.literal" (ppr other) -push_alts WordRep = bci_PUSH_ALTS_N -push_alts IntRep = bci_PUSH_ALTS_N -push_alts AddrRep = bci_PUSH_ALTS_N -push_alts CharRep = bci_PUSH_ALTS_N -push_alts FloatRep = bci_PUSH_ALTS_F -push_alts DoubleRep = bci_PUSH_ALTS_D -push_alts VoidRep = bci_PUSH_ALTS_V -push_alts pk - | is64BitRep pk = bci_PUSH_ALTS_L - | isFollowableRep pk = bci_PUSH_ALTS_P - -return_ubx WordRep = bci_RETURN_N -return_ubx IntRep = bci_RETURN_N -return_ubx AddrRep = bci_RETURN_N -return_ubx CharRep = bci_RETURN_N -return_ubx FloatRep = bci_RETURN_F -return_ubx DoubleRep = bci_RETURN_D -return_ubx VoidRep = bci_RETURN_V -return_ubx pk - | is64BitRep pk = bci_RETURN_L - | isFollowableRep pk = bci_RETURN_P +push_alts NonPtrArg = bci_PUSH_ALTS_N +push_alts FloatArg = bci_PUSH_ALTS_F +push_alts DoubleArg = bci_PUSH_ALTS_D +push_alts VoidArg = bci_PUSH_ALTS_V +push_alts LongArg = bci_PUSH_ALTS_L +push_alts PtrArg = bci_PUSH_ALTS_P + +return_ubx NonPtrArg = bci_RETURN_N +return_ubx FloatArg = bci_RETURN_F +return_ubx DoubleArg = bci_RETURN_D +return_ubx VoidArg = bci_RETURN_V +return_ubx LongArg = bci_RETURN_L +return_ubx PtrArg = bci_RETURN_P -- The size in 16-bit entities of an instruction. diff --git a/ghc/compiler/ghci/ByteCodeFFI.lhs b/ghc/compiler/ghci/ByteCodeFFI.lhs index 78cfa610b2..fe258dd7cf 100644 --- a/ghc/compiler/ghci/ByteCodeFFI.lhs +++ b/ghc/compiler/ghci/ByteCodeFFI.lhs @@ -9,7 +9,7 @@ module ByteCodeFFI ( mkMarshalCode, moan64 ) where #include "HsVersions.h" import Outputable -import PrimRep ( PrimRep(..), getPrimRepSize ) +import SMRep ( CgRep(..), cgRepSizeW ) import ForeignCall ( CCallConv(..) ) -- DON'T remove apparently unused imports here .. @@ -66,7 +66,7 @@ itself expects only to be called using the ccall convention -- that is, we don't clear our own (single) arg off the C stack. -} mkMarshalCode :: CCallConv - -> (Int, PrimRep) -> Int -> [(Int, PrimRep)] + -> (Int, CgRep) -> Int -> [(Int, CgRep)] -> IO (Ptr Word8) mkMarshalCode cconv (r_offW, r_rep) addr_offW arg_offs_n_reps = let bytes = mkMarshalCode_wrk cconv (r_offW, r_rep) @@ -77,7 +77,7 @@ mkMarshalCode cconv (r_offW, r_rep) addr_offW arg_offs_n_reps mkMarshalCode_wrk :: CCallConv - -> (Int, PrimRep) -> Int -> [(Int, PrimRep)] + -> (Int, CgRep) -> Int -> [(Int, CgRep)] -> [Word8] mkMarshalCode_wrk cconv (r_offW, r_rep) addr_offW arg_offs_n_reps @@ -90,7 +90,7 @@ mkMarshalCode_wrk cconv (r_offW, r_rep) addr_offW arg_offs_n_reps offsets_to_pushW = concat [ -- reversed because x86 is little-endian - reverse [a_offW .. a_offW + getPrimRepSize a_rep - 1] + reverse [a_offW .. a_offW + cgRepSizeW a_rep - 1] -- reversed because args are pushed L -> R onto C stack | (a_offW, a_rep) <- reverse arg_offs_n_reps @@ -187,7 +187,7 @@ mkMarshalCode_wrk cconv (r_offW, r_rep) addr_offW arg_offs_n_reps ++ movl_offespmem_esi 32 {- For each arg in args_offs_n_reps, examine the associated - PrimRep to determine how many words there are. This gives a + CgRep to determine how many words there are. This gives a bunch of offsets on the H stack to copy to the C stack: movl off1(%esi), %ecx @@ -235,15 +235,11 @@ mkMarshalCode_wrk cconv (r_offW, r_rep) addr_offW arg_offs_n_reps f64 = fstpl_offesimem 0 in case r_rep of - CharRep -> i32 - IntRep -> i32 - WordRep -> i32 - AddrRep -> i32 - DoubleRep -> f64 - FloatRep -> f32 - -- Word64Rep -> i64 - -- Int64Rep -> i64 - VoidRep -> [] + NonPtrArg -> i32 + DoubleArg -> f64 + FloatArg -> f32 + -- LongArg -> i64 + VoidArg -> [] other -> moan64 "ByteCodeFFI.mkMarshalCode_wrk(x86)" (ppr r_rep) @@ -278,7 +274,7 @@ mkMarshalCode_wrk cconv (r_offW, r_rep) addr_offW arg_offs_n_reps offsets_to_pushW = concat - [ [a_offW .. a_offW + getPrimRepSize a_rep - 1] + [ [a_offW .. a_offW + cgRepSizeW a_rep - 1] | (a_offW, a_rep) <- arg_offs_n_reps ] @@ -385,7 +381,7 @@ mkMarshalCode_wrk cconv (r_offW, r_rep) addr_offW arg_offs_n_reps [mkSAVE sp (- ({-92-}112 + 4*argWs_on_stack_ROUNDED_UP)) sp] {- For each arg in args_offs_n_reps, examine the associated - PrimRep to determine how many words there are. This gives a + CgRep to determine how many words there are. This gives a bunch of offsets on the H stack. Move the first 6 words into %o0 .. %o5 and the rest on the stack, starting at [%sp+92]. Use %g1 as a temp. @@ -429,13 +425,10 @@ mkMarshalCode_wrk cconv (r_offW, r_rep) addr_offW arg_offs_n_reps f64 = [mkSTF f0 i0 0, mkSTF f1 i0 4] in case r_rep of - CharRep -> i32 - IntRep -> i32 - WordRep -> i32 - AddrRep -> i32 - DoubleRep -> f64 - FloatRep -> f32 - VoidRep -> [] + NonPtrArg -> i32 + DoubleArg -> f64 + FloatArg -> f32 + VoidArg -> [] other -> moan64 "ByteCodeFFI.mkMarshalCode_wrk(sparc)" (ppr r_rep) @@ -460,7 +453,7 @@ mkMarshalCode_wrk cconv (r_offW, r_rep) addr_offW arg_offs_n_reps result_off = r_offW * bytes_per_word linkageArea = 24 - parameterArea = sum [ getPrimRepSize a_rep * bytes_per_word + parameterArea = sum [ cgRepSizeW a_rep * bytes_per_word | (_, a_rep) <- arg_offs_n_reps ] savedRegisterArea = 4 frameSize = padTo16 (linkageArea + max parameterArea 32 + savedRegisterArea) @@ -472,7 +465,7 @@ mkMarshalCode_wrk cconv (r_offW, r_rep) addr_offW arg_offs_n_reps pass_parameters ((a_offW, a_rep):args) nextFPR offsetW = let haskellArgOffset = a_offW * bytes_per_word - offsetW' = offsetW + getPrimRepSize a_rep + offsetW' = offsetW + cgRepSizeW a_rep pass_word w | offsetW + w < 8 = @@ -489,34 +482,34 @@ mkMarshalCode_wrk cconv (r_offW, r_rep) addr_offW arg_offs_n_reps dst = linkageArea + (offsetW+w) * bytes_per_word in case a_rep of - FloatRep | nextFPR < 14 -> + FloatArg | nextFPR < 14 -> (0xc01f0000 -- lfs fX, haskellArgOffset(r31) .|. (fromIntegral haskellArgOffset .&. 0xFFFF) .|. (fromIntegral nextFPR `shiftL` 21)) : pass_parameters args (nextFPR+1) offsetW' - DoubleRep | nextFPR < 14 -> + DoubleArg | nextFPR < 14 -> (0xc81f0000 -- lfd fX, haskellArgOffset(r31) .|. (fromIntegral haskellArgOffset .&. 0xFFFF) .|. (fromIntegral nextFPR `shiftL` 21)) : pass_parameters args (nextFPR+1) offsetW' _ -> - concatMap pass_word [0 .. getPrimRepSize a_rep - 1] + concatMap pass_word [0 .. cgRepSizeW a_rep - 1] ++ pass_parameters args nextFPR offsetW' gather_result = case r_rep of - VoidRep -> [] - FloatRep -> + VoidArg -> [] + FloatArg -> [0xd03f0000 .|. (fromIntegral result_off .&. 0xFFFF)] -- stfs f1, result_off(r31) - DoubleRep -> + DoubleArg -> [0xd83f0000 .|. (fromIntegral result_off .&. 0xFFFF)] -- stfs f1, result_off(r31) - _ | getPrimRepSize r_rep == 2 -> + _ | cgRepSizeW r_rep == 2 -> [0x907f0000 .|. (fromIntegral result_off .&. 0xFFFF), 0x909f0000 .|. (fromIntegral (result_off+4) .&. 0xFFFF)] -- stw r3, result_off(r31) -- stw r4, result_off+4(r31) - _ | getPrimRepSize r_rep == 1 -> + _ | cgRepSizeW r_rep == 1 -> [0x907f0000 .|. (fromIntegral result_off .&. 0xFFFF)] -- stw r3, result_off(r31) in diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs index d7a477bfdc..f7256f3f77 100644 --- a/ghc/compiler/ghci/ByteCodeGen.lhs +++ b/ghc/compiler/ghci/ByteCodeGen.lhs @@ -23,11 +23,10 @@ import HscTypes ( TypeEnv, typeEnvTyCons, typeEnvClasses ) import CoreUtils ( exprType ) import CoreSyn import PprCore ( pprCoreExpr ) -import Literal ( Literal(..), literalPrimRep ) -import PrimRep +import Literal ( Literal(..), literalType ) import PrimOp ( PrimOp(..) ) import CoreFVs ( freeVars ) -import Type ( typePrimRep, isUnLiftedType, splitTyConApp_maybe ) +import Type ( isUnLiftedType, splitTyConApp_maybe ) import DataCon ( DataCon, dataConTag, fIRST_TAG, dataConTyCon, isUnboxedTupleCon, isNullaryDataCon, dataConWorkId, dataConRepArity ) @@ -42,13 +41,13 @@ import VarSet ( VarSet, varSetElems ) import TysPrim ( arrayPrimTyCon, mutableArrayPrimTyCon, byteArrayPrimTyCon, mutableByteArrayPrimTyCon ) -import PrimRep ( isFollowableRep ) import CmdLineOpts ( DynFlags, DynFlag(..) ) import ErrUtils ( showPass, dumpIfSet_dyn ) -import Unique ( mkPseudoUnique3 ) +import Unique ( mkPseudoUniqueE ) import FastString ( FastString(..), unpackFS ) import Panic ( GhcException(..) ) -import SMRep ( arrWordsHdrSize, arrPtrsHdrSize, StgWord ) +import SMRep ( typeCgRep, arrWordsHdrSize, arrPtrsHdrSize, StgWord, + CgRep(..), cgRepSizeW, isFollowableArg, idCgRep ) import Bitmap ( intsToReverseBitmap, mkBitmap ) import OrdList import Constants ( wORD_SIZE ) @@ -103,7 +102,7 @@ coreExprToBCOs dflags expr -- create a totally bogus name for the top-level BCO; this -- should be harmless, since it's never used for anything - let invented_name = mkSystemName (mkPseudoUnique3 0) FSLIT("ExprTopLevel") + let invented_name = mkSystemName (mkPseudoUniqueE 0) FSLIT("ExprTopLevel") invented_id = mkLocalId invented_name (panic "invented_id's type") (BcM_State final_ctr mallocd, proto_bco) @@ -134,7 +133,7 @@ ppBCEnv p $$ nest 4 (vcat (map pp_one (sortBy cmp_snd (fmToList p)))) $$ text "end-env" where - pp_one (var, offset) = int offset <> colon <+> ppr var <+> ppr (idPrimRep var) + pp_one (var, offset) = int offset <> colon <+> ppr var <+> ppr (idCgRep var) cmp_snd x y = compare (snd x) (snd y) -- Create a BCO and do a spot of peephole optimisation on the insns @@ -195,11 +194,11 @@ mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap peep [] = [] -argBits :: [PrimRep] -> [Bool] +argBits :: [CgRep] -> [Bool] argBits [] = [] argBits (rep : args) - | isFollowableRep rep = False : argBits args - | otherwise = take (getPrimRepSize rep) (repeat True) ++ argBits args + | isFollowableArg rep = False : argBits args + | otherwise = take (cgRepSizeW rep) (repeat True) ++ argBits args -- ----------------------------------------------------------------------------- -- schemeTopBind @@ -272,7 +271,7 @@ schemeR_wrk fvs nm original_body (args, body) p_init = listToFM (zip all_args (mkStackOffsets 0 szsw_args)) -- make the arg bitmap - bits = argBits (reverse (map idPrimRep all_args)) + bits = argBits (reverse (map idCgRep all_args)) bitmap_size = length bits bitmap = mkBitmap bits in @@ -319,11 +318,11 @@ schemeE d s p e@(AnnVar v) `snocOL` RETURN_UBX v_rep) -- go where v_type = idType v - v_rep = typePrimRep v_type + v_rep = typeCgRep v_type schemeE d s p (AnnLit literal) = pushAtom d p (AnnLit literal) `thenBc` \ (push, szw) -> - let l_rep = literalPrimRep literal + let l_rep = typeCgRep (literalType literal) in returnBc (push -- value onto stack `appOL` mkSLIDE szw (d-s) -- clear to sequel `snocOL` RETURN_UBX l_rep) -- go @@ -393,9 +392,9 @@ schemeE d s p (AnnLet binds (_,body)) schemeE d s p (AnnCase scrut bndr [(DataAlt dc, [bind1, bind2], rhs)]) - | isUnboxedTupleCon dc && VoidRep == typePrimRep (idType bind1) + | isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind1) -- Convert - -- case .... of x { (# VoidRep'd-thing, a #) -> ... } + -- case .... of x { (# VoidArg'd-thing, a #) -> ... } -- to -- case .... of a { DEFAULT -> ... } -- becuse the return convention for both are identical. @@ -403,11 +402,11 @@ schemeE d s p (AnnCase scrut bndr [(DataAlt dc, [bind1, bind2], rhs)]) -- Note that it does not matter losing the void-rep thing from the -- envt (it won't be bound now) because we never look such things up. - = --trace "automagic mashing of case alts (# VoidRep, a #)" $ + = --trace "automagic mashing of case alts (# VoidArg, a #)" $ doCase d s p scrut bind2 [(DEFAULT, [], rhs)] True{-unboxed tuple-} - | isUnboxedTupleCon dc && VoidRep == typePrimRep (idType bind2) - = --trace "automagic mashing of case alts (# a, VoidRep #)" $ + | isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind2) + = --trace "automagic mashing of case alts (# a, VoidArg #)" $ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-} schemeE d s p (AnnCase scrut bndr [(DataAlt dc, [bind1], rhs)]) @@ -441,9 +440,9 @@ schemeE d s p other -- -- 1. The fn denotes a ccall. Defer to generateCCall. -- --- 2. (Another nasty hack). Spot (# a::VoidRep, b #) and treat +-- 2. (Another nasty hack). Spot (# a::VoidArg, b #) and treat -- it simply as b -- since the representations are identical --- (the VoidRep takes up zero stack space). Also, spot +-- (the VoidArg takes up zero stack space). Also, spot -- (# b #) and treat it as b. -- -- 3. Application of a constructor, by defn saturated. @@ -483,9 +482,9 @@ schemeT d s p app | Just con <- maybe_saturated_dcon, isUnboxedTupleCon con = case args_r_to_l of - [arg1,arg2] | isVoidRepAtom arg1 -> + [arg1,arg2] | isVoidArgAtom arg1 -> unboxedTupleReturn d s p arg2 - [arg1,arg2] | isVoidRepAtom arg2 -> + [arg1,arg2] | isVoidArgAtom arg2 -> unboxedTupleReturn d s p arg1 _other -> unboxedTupleException @@ -589,7 +588,7 @@ doTailCall -> Id -> [AnnExpr' Id VarSet] -> BcM BCInstrList doTailCall init_d s p fn args - = do_pushes init_d args (map (primRepToArgRep.atomRep) args) + = do_pushes init_d args (map atomRep args) where do_pushes d [] reps = do ASSERTM( null reps ) @@ -613,29 +612,29 @@ doTailCall init_d s p fn args return (final_d, push_code `appOL` more_push_code) -- v. similar to CgStackery.findMatch, ToDo: merge -findPushSeq (RepP: RepP: RepP: RepP: RepP: RepP: RepP: rest) +findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: rest) = (PUSH_APPLY_PPPPPPP, 7, rest) -findPushSeq (RepP: RepP: RepP: RepP: RepP: RepP: rest) +findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: rest) = (PUSH_APPLY_PPPPPP, 6, rest) -findPushSeq (RepP: RepP: RepP: RepP: RepP: rest) +findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: rest) = (PUSH_APPLY_PPPPP, 5, rest) -findPushSeq (RepP: RepP: RepP: RepP: rest) +findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: rest) = (PUSH_APPLY_PPPP, 4, rest) -findPushSeq (RepP: RepP: RepP: rest) +findPushSeq (PtrArg: PtrArg: PtrArg: rest) = (PUSH_APPLY_PPP, 3, rest) -findPushSeq (RepP: RepP: rest) +findPushSeq (PtrArg: PtrArg: rest) = (PUSH_APPLY_PP, 2, rest) -findPushSeq (RepP: rest) +findPushSeq (PtrArg: rest) = (PUSH_APPLY_P, 1, rest) -findPushSeq (RepV: rest) +findPushSeq (VoidArg: rest) = (PUSH_APPLY_V, 1, rest) -findPushSeq (RepN: rest) +findPushSeq (NonPtrArg: rest) = (PUSH_APPLY_N, 1, rest) -findPushSeq (RepF: rest) +findPushSeq (FloatArg: rest) = (PUSH_APPLY_F, 1, rest) -findPushSeq (RepD: rest) +findPushSeq (DoubleArg: rest) = (PUSH_APPLY_D, 1, rest) -findPushSeq (RepL: rest) +findPushSeq (LongArg: rest) = (PUSH_APPLY_L, 1, rest) findPushSeq _ = panic "ByteCodeGen.findPushSeq" @@ -688,7 +687,7 @@ doCase d s p (_,scrut) -- algebraic alt with some binders | ASSERT(isAlgCase) otherwise = let - (ptrs,nptrs) = partition (isFollowableRep.idPrimRep) real_bndrs + (ptrs,nptrs) = partition (isFollowableArg.idCgRep) real_bndrs ptr_sizes = map idSizeW ptrs nptrs_sizes = map idSizeW nptrs bind_sizes = ptr_sizes ++ nptrs_sizes @@ -736,7 +735,7 @@ doCase d s p (_,scrut) binds = fmToList p rel_slots = concat (map spread binds) spread (id, offset) - | isFollowableRep (idPrimRep id) = [ rel_offset ] + | isFollowableArg (idCgRep id) = [ rel_offset ] | otherwise = [] where rel_offset = d - offset - 1 @@ -754,7 +753,7 @@ doCase d s p (_,scrut) alt_bco' <- emitBc alt_bco let push_alts | isAlgCase = PUSH_ALTS alt_bco' - | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typePrimRep bndr_ty) + | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeCgRep bndr_ty) returnBc (push_alts `consOL` scrut_code) @@ -777,12 +776,12 @@ generateCCall :: Int -> Sequel -- stack and sequel depths generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l = let -- useful constants - addr_sizeW = getPrimRepSize AddrRep + addr_sizeW = cgRepSizeW NonPtrArg -- Get the args on the stack, with tags and suitably -- dereferenced for the CCall. For each arg, return the -- depth to the first word of the bits for that arg, and the - -- PrimRep of what was actually pushed. + -- CgRep of what was actually pushed. pargs d [] = returnBc [] pargs d (a:az) @@ -796,13 +795,13 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l -> pargs (d + addr_sizeW) az `thenBc` \ rest -> parg_ArrayishRep arrPtrsHdrSize d p a `thenBc` \ code -> - returnBc ((code,AddrRep):rest) + returnBc ((code,NonPtrArg):rest) | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon -> pargs (d + addr_sizeW) az `thenBc` \ rest -> parg_ArrayishRep arrWordsHdrSize d p a `thenBc` \ code -> - returnBc ((code,AddrRep):rest) + returnBc ((code,NonPtrArg):rest) -- Default case: push taggedly, but otherwise intact. other @@ -813,13 +812,11 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l -- Do magic for Ptr/Byte arrays. Push a ptr to the array on -- the stack but then advance it over the headers, so as to -- point to the payload. - parg_ArrayishRep hdrSizeW d p a + parg_ArrayishRep hdrSize d p a = pushAtom d p a `thenBc` \ (push_fo, _) -> -- The ptr points at the header. Advance it over the -- header and then pretend this is an Addr#. - returnBc (push_fo `snocOL` - SWIZZLE 0 (hdrSizeW * getPrimRepSize WordRep - * wORD_SIZE)) + returnBc (push_fo `snocOL` SWIZZLE 0 hdrSize) in pargs d0 args_r_to_l `thenBc` \ code_n_reps -> @@ -827,9 +824,9 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l (pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps push_args = concatOL pushs_arg - d_after_args = d0 + sum (map getPrimRepSize a_reps_pushed_r_to_l) + d_after_args = d0 + sum (map cgRepSizeW a_reps_pushed_r_to_l) a_reps_pushed_RAW - | null a_reps_pushed_r_to_l || head a_reps_pushed_r_to_l /= VoidRep + | null a_reps_pushed_r_to_l || head a_reps_pushed_r_to_l /= VoidArg = panic "ByteCodeGen.generateCCall: missing or invalid World token?" | otherwise = reverse (tail a_reps_pushed_r_to_l) @@ -841,7 +838,7 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l -- Get the result rep. (returns_void, r_rep) = case maybe_getCCallReturnRep (idType fn) of - Nothing -> (True, VoidRep) + Nothing -> (True, VoidArg) Just rr -> (False, rr) {- Because the Haskell stack grows down, the a_reps refer to @@ -906,8 +903,8 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l = (nilOL, d_after_args) -- Push the return placeholder. For a call returning nothing, - -- this is a VoidRep (tag). - r_sizeW = getPrimRepSize r_rep + -- this is a VoidArg (tag). + r_sizeW = cgRepSizeW r_rep d_after_r = d_after_Addr + r_sizeW r_lit = mkDummyLiteral r_rep push_r = (if returns_void @@ -919,7 +916,7 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l addr_offW = r_sizeW arg1_offW = r_sizeW + addr_sizeW args_offW = map (arg1_offW +) - (init (scanl (+) 0 (map getPrimRepSize a_reps))) + (init (scanl (+) 0 (map cgRepSizeW a_reps))) in ioToBc (mkMarshalCode cconv (r_offW, r_rep) addr_offW @@ -938,7 +935,7 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l wrapup = mkSLIDE r_sizeW (d_after_r - r_sizeW - s) `snocOL` RETURN_UBX r_rep in - --trace (show (arg1_offW, args_offW , (map getPrimRepSize a_reps) )) $ + --trace (show (arg1_offW, args_offW , (map cgRepSizeW a_reps) )) $ returnBc ( push_args `appOL` push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup @@ -947,15 +944,12 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l -- Make a dummy literal, to be used as a placeholder for FFI return -- values on the stack. -mkDummyLiteral :: PrimRep -> Literal +mkDummyLiteral :: CgRep -> Literal mkDummyLiteral pr = case pr of - CharRep -> MachChar (chr 0) - IntRep -> MachInt 0 - WordRep -> MachWord 0 - DoubleRep -> MachDouble 0 - FloatRep -> MachFloat 0 - AddrRep | getPrimRepSize AddrRep == getPrimRepSize WordRep -> MachWord 0 + NonPtrArg -> MachWord 0 + DoubleArg -> MachDouble 0 + FloatArg -> MachFloat 0 _ -> moan64 "mkDummyLiteral" (ppr pr) @@ -964,7 +958,7 @@ mkDummyLiteral pr -- -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #) -- -- to Just IntRep --- and check that an unboxed pair is returned wherein the first arg is VoidRep'd. +-- and check that an unboxed pair is returned wherein the first arg is VoidArg'd. -- -- Alternatively, for call-targets returning nothing, convert -- @@ -973,21 +967,21 @@ mkDummyLiteral pr -- -- to Nothing -maybe_getCCallReturnRep :: Type -> Maybe PrimRep +maybe_getCCallReturnRep :: Type -> Maybe CgRep maybe_getCCallReturnRep fn_ty = let (a_tys, r_ty) = splitFunTys (dropForAlls fn_ty) maybe_r_rep_to_go = if isSingleton r_reps then Nothing else Just (r_reps !! 1) (r_tycon, r_reps) = case splitTyConApp_maybe (repType r_ty) of - (Just (tyc, tys)) -> (tyc, map typePrimRep tys) + (Just (tyc, tys)) -> (tyc, map typeCgRep tys) Nothing -> blargh - ok = ( ( r_reps `lengthIs` 2 && VoidRep == head r_reps) - || r_reps == [VoidRep] ) + ok = ( ( r_reps `lengthIs` 2 && VoidArg == head r_reps) + || r_reps == [VoidArg] ) && isUnboxedTupleTyCon r_tycon && case maybe_r_rep_to_go of Nothing -> True - Just r_rep -> r_rep /= PtrRep + Just r_rep -> r_rep /= PtrArg -- if it was, it would be impossible -- to create a valid return value -- placeholder on the stack @@ -1047,7 +1041,7 @@ pushAtom d p (AnnLam x e) pushAtom d p (AnnVar v) - | idPrimRep v == VoidRep + | idCgRep v == VoidArg = returnBc (nilOL, 0) | isFCallId v @@ -1079,16 +1073,16 @@ pushAtom d p (AnnVar v) pushAtom d p (AnnLit lit) = case lit of - MachLabel fs _ -> code CodePtrRep - MachWord w -> code WordRep - MachInt i -> code IntRep - MachFloat r -> code FloatRep - MachDouble r -> code DoubleRep - MachChar c -> code CharRep + MachLabel fs _ -> code NonPtrArg + MachWord w -> code NonPtrArg + MachInt i -> code PtrArg + MachFloat r -> code FloatArg + MachDouble r -> code DoubleArg + MachChar c -> code NonPtrArg MachStr s -> pushStr s where code rep - = let size_host_words = getPrimRepSize rep + = let size_host_words = cgRepSizeW rep in returnBc (unitOL (PUSH_UBX (Left lit) size_host_words), size_host_words) @@ -1256,7 +1250,7 @@ lookupBCEnv_maybe :: BCEnv -> Id -> Maybe Int lookupBCEnv_maybe = lookupFM idSizeW :: Id -> Int -idSizeW id = getPrimRepSize (typePrimRep (idType id)) +idSizeW id = cgRepSizeW (typeCgRep (idType id)) unboxedTupleException :: a unboxedTupleException @@ -1284,21 +1278,21 @@ isTypeAtom :: AnnExpr' id ann -> Bool isTypeAtom (AnnType _) = True isTypeAtom _ = False -isVoidRepAtom :: AnnExpr' id ann -> Bool -isVoidRepAtom (AnnVar v) = typePrimRep (idType v) == VoidRep -isVoidRepAtom (AnnNote n (_,e)) = isVoidRepAtom e -isVoidRepAtom _ = False +isVoidArgAtom :: AnnExpr' id ann -> Bool +isVoidArgAtom (AnnVar v) = typeCgRep (idType v) == VoidArg +isVoidArgAtom (AnnNote n (_,e)) = isVoidArgAtom e +isVoidArgAtom _ = False -atomRep :: AnnExpr' Id ann -> PrimRep -atomRep (AnnVar v) = typePrimRep (idType v) -atomRep (AnnLit l) = literalPrimRep l +atomRep :: AnnExpr' Id ann -> CgRep +atomRep (AnnVar v) = typeCgRep (idType v) +atomRep (AnnLit l) = typeCgRep (literalType l) atomRep (AnnNote n b) = atomRep (snd b) atomRep (AnnApp f (_, AnnType _)) = atomRep (snd f) atomRep (AnnLam x e) | isTyVar x = atomRep (snd e) atomRep other = pprPanic "atomRep" (ppr (deAnnotate (undefined,other))) isPtrAtom :: AnnExpr' Id ann -> Bool -isPtrAtom e = isFollowableRep (atomRep e) +isPtrAtom e = atomRep e == PtrArg -- Let szsw be the sizes in words of some items pushed onto the stack, -- which has initial depth d'. Return the values which the stack environment diff --git a/ghc/compiler/ghci/ByteCodeInstr.lhs b/ghc/compiler/ghci/ByteCodeInstr.lhs index 05c4fe4734..43c551549f 100644 --- a/ghc/compiler/ghci/ByteCodeInstr.lhs +++ b/ghc/compiler/ghci/ByteCodeInstr.lhs @@ -17,11 +17,10 @@ import Id ( Id ) import CoreSyn import PprCore ( pprCoreExpr, pprCoreAlt ) import Literal ( Literal ) -import PrimRep ( PrimRep ) import DataCon ( DataCon ) import VarSet ( VarSet ) import PrimOp ( PrimOp ) -import SMRep ( StgWord ) +import SMRep ( StgWord, CgRep ) import GHC.Ptr -- ---------------------------------------------------------------------------- @@ -59,7 +58,7 @@ data BCInstr -- Push an alt continuation | PUSH_ALTS (ProtoBCO Name) - | PUSH_ALTS_UNLIFTED (ProtoBCO Name) PrimRep + | PUSH_ALTS_UNLIFTED (ProtoBCO Name) CgRep -- Pushing literals | PUSH_UBX (Either Literal (Ptr ())) Int @@ -125,7 +124,7 @@ data BCInstr -- To Infinity And Beyond | ENTER | RETURN -- return a lifted value - | RETURN_UBX PrimRep -- return an unlifted value, here's its rep + | RETURN_UBX CgRep -- return an unlifted value, here's its rep -- ----------------------------------------------------------------------------- -- Printing bytecode instructions diff --git a/ghc/compiler/ghci/ByteCodeItbls.lhs b/ghc/compiler/ghci/ByteCodeItbls.lhs index 5325f8f29e..c44e562bc0 100644 --- a/ghc/compiler/ghci/ByteCodeItbls.lhs +++ b/ghc/compiler/ghci/ByteCodeItbls.lhs @@ -13,11 +13,11 @@ module ByteCodeItbls ( ItblEnv, ItblPtr, mkITbls ) where import Name ( Name, getName ) import NameEnv -import Type ( typePrimRep ) +import SMRep ( typeCgRep ) import DataCon ( DataCon, dataConRepArgTys ) import TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons ) import Constants ( mIN_SIZE_NonUpdHeapObject ) -import ClosureInfo ( mkVirtHeapOffsets ) +import CgHeapery ( mkVirtHeapOffsets ) import FastString ( FastString(..) ) import Util ( lengthIs, listLengthCmp ) @@ -87,8 +87,10 @@ make_constr_itbls cons mk_itbl :: DataCon -> Int -> Ptr () -> IO (Name,ItblPtr) mk_itbl dcon conNo entry_addr - = let (tot_wds, ptr_wds, _) - = mkVirtHeapOffsets typePrimRep (dataConRepArgTys dcon) + = let rep_args = [ (typeCgRep arg,arg) + | arg <- dataConRepArgTys dcon ] + (tot_wds, ptr_wds, _) = mkVirtHeapOffsets rep_args + ptrs = ptr_wds nptrs = tot_wds - ptr_wds nptrs_really diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index c4b5aeb934..38b24854cf 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -1,6 +1,6 @@ {-# OPTIONS -#include "Linker.h" #-} ----------------------------------------------------------------------------- --- $Id: InteractiveUI.hs,v 1.172 2004/08/12 13:10:35 simonmar Exp $ +-- $Id: InteractiveUI.hs,v 1.173 2004/08/13 13:06:42 simonmar Exp $ -- -- GHC Interactive User Interface -- @@ -12,7 +12,7 @@ module InteractiveUI ( ghciWelcomeMsg ) where -#include "../includes/config.h" +#include "../includes/ghcconfig.h" #include "HsVersions.h" import CompManager diff --git a/ghc/compiler/ghci/Linker.lhs b/ghc/compiler/ghci/Linker.lhs index 0879aa3a79..0849859bae 100644 --- a/ghc/compiler/ghci/Linker.lhs +++ b/ghc/compiler/ghci/Linker.lhs @@ -20,7 +20,7 @@ module Linker ( HValue, showLinkerState, linkPackages, ) where -#include "../includes/config.h" +#include "../includes/ghcconfig.h" #include "HsVersions.h" import ObjLink ( loadDLL, loadObj, unloadObj, resolveObjs, initObjLinker ) diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index 827bec8708..3a610024a3 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -40,12 +40,11 @@ import HscTypes ( DeprecTxt ) import CoreSyn ( RuleName ) import BasicTypes ( Activation(..) ) import ForeignCall ( CCallTarget(..), DNCallSpec, CCallConv, Safety, - CExportSpec(..)) + CExportSpec(..), CLabelString ) -- others: import FunDeps ( pprFundeps ) import Class ( FunDep ) -import CStrings ( CLabelString ) import Outputable import Util ( count ) import SrcLoc ( Located(..), unLoc ) diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index b68d236597..64ed4adaf5 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -210,7 +210,7 @@ data FloatOutSwitches data DynFlag -- debugging flags - = Opt_D_dump_absC + = Opt_D_dump_cmm | Opt_D_dump_asm | Opt_D_dump_cpranal | Opt_D_dump_deriv @@ -220,7 +220,6 @@ data DynFlag | Opt_D_dump_inlinings | Opt_D_dump_occur_anal | Opt_D_dump_parsed - | Opt_D_dump_realC | Opt_D_dump_rn | Opt_D_dump_simpl | Opt_D_dump_simpl_iterations @@ -235,7 +234,7 @@ data DynFlag | Opt_D_dump_worker_wrapper | Opt_D_dump_rn_trace | Opt_D_dump_rn_stats - | Opt_D_dump_stix + | Opt_D_dump_opt_cmm | Opt_D_dump_simpl_stats | Opt_D_dump_tc_trace | Opt_D_dump_if_trace @@ -250,6 +249,7 @@ data DynFlag | Opt_D_dump_minimal_imports | Opt_DoCoreLinting | Opt_DoStgLinting + | Opt_DoCmmLinting | Opt_WarnIsError -- -Werror; makes warnings fatal | Opt_WarnDuplicateExports diff --git a/ghc/compiler/main/CodeOutput.lhs b/ghc/compiler/main/CodeOutput.lhs index 9a24fc07d2..7732497a64 100644 --- a/ghc/compiler/main/CodeOutput.lhs +++ b/ghc/compiler/main/CodeOutput.lhs @@ -24,25 +24,27 @@ import qualified PrintJava import OccurAnal ( occurAnalyseBinds ) #endif +import PprC ( writeCs ) +import CmmLint ( cmmLint ) import Packages import DriverState ( getExplicitPackagesAnd, getPackageCIncludes ) import FastString ( unpackFS ) -import AbsCSyn ( AbstractC ) -import PprAbsC ( dumpRealC, writeRealC ) +import Cmm ( Cmm ) import HscTypes import CmdLineOpts -import ErrUtils ( dumpIfSet_dyn, showPass ) +import ErrUtils ( dumpIfSet_dyn, showPass, ghcExit ) import Outputable import Pretty ( Mode(..), printDoc ) import Module ( Module ) import ListSetOps ( removeDupsEq ) +import Maybes ( firstJust ) -import Directory ( doesFileExist ) +import Directory ( doesFileExist ) +import Data.List ( intersperse ) import Monad ( when ) import IO \end{code} - %************************************************************************ %* * \subsection{Steering} @@ -54,7 +56,7 @@ codeOutput :: DynFlags -> Module -> ForeignStubs -> Dependencies - -> AbstractC -- Compiled abstract C + -> [Cmm] -- Compiled C-- -> IO (Bool{-stub_h_exists-}, Bool{-stub_c_exists-}) codeOutput dflags this_mod foreign_stubs deps flat_abstractC @@ -65,7 +67,17 @@ codeOutput dflags this_mod foreign_stubs deps flat_abstractC -- Dunno if the above comment is still meaningful now. JRS 001024. - do { showPass dflags "CodeOutput" + do { when (dopt Opt_DoCmmLinting dflags) $ do + { showPass dflags "CmmLint" + ; let lints = map cmmLint flat_abstractC + ; case firstJust lints of + Just err -> do { printDump err + ; ghcExit 1 + } + Nothing -> return () + } + + ; showPass dflags "CodeOutput" ; let filenm = dopt_OutName dflags ; stubs_exist <- outputForeignStubs dflags foreign_stubs ; case dopt_HscLang dflags of { @@ -104,8 +116,7 @@ doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action \begin{code} outputC dflags filenm flat_absC (stub_h_exists, _) dependencies foreign_stubs - = do dumpIfSet_dyn dflags Opt_D_dump_realC "Real C" (dumpRealC flat_absC) - + = do -- figure out which header files to #include in the generated .hc file: -- -- * extra_includes from packages @@ -142,7 +153,7 @@ outputC dflags filenm flat_absC hPutStr h cc_injects when stub_h_exists $ hPutStrLn h ("#include \"" ++ (hscStubHOutName dflags) ++ "\"") - writeRealC h flat_absC + writeCs h flat_absC \end{code} @@ -158,9 +169,8 @@ outputAsm dflags filenm flat_absC #ifndef OMIT_NATIVE_CODEGEN = do ncg_uniqs <- mkSplitUniqSupply 'n' - let (stix_final, ncg_output_d) = _scc_ "NativeCodeGen" - nativeCodeGen flat_absC ncg_uniqs - dumpIfSet_dyn dflags Opt_D_dump_stix "Final stix code" stix_final + ncg_output_d <- _scc_ "NativeCodeGen" + nativeCodeGen dflags flat_absC ncg_uniqs dumpIfSet_dyn dflags Opt_D_dump_asm "Asm code" (docToSDoc ncg_output_d) _scc_ "OutputAsm" doOutput filenm $ \f -> printDoc LeftMode f ncg_output_d @@ -247,7 +257,7 @@ outputForeignStubs dflags (ForeignStubs h_code c_code _ _) stub_c_file_exists <- outputForeignStubs_help (hscStubCOutName dflags) stub_c_output_w ("#define IN_STG_CODE 0\n" ++ - "#include \"RtsAPI.h\"\n" ++ + "#include \"Rts.h\"\n" ++ rts_includes ++ cplusplus_hdr) cplusplus_ftr diff --git a/ghc/compiler/main/Constants.lhs b/ghc/compiler/main/Constants.lhs index 9d6a7cc638..091a7de4dc 100644 --- a/ghc/compiler/main/Constants.lhs +++ b/ghc/compiler/main/Constants.lhs @@ -4,68 +4,7 @@ \section[Constants]{Info about this compilation} \begin{code} -module Constants ( - mAX_CONTEXT_REDUCTION_DEPTH, - mAX_TUPLE_SIZE, - - mAX_SPEC_THUNK_SIZE, - mAX_SPEC_FUN_SIZE, - mAX_SPEC_CONSTR_SIZE, - mAX_SPEC_SELECTEE_SIZE, - mAX_SPEC_AP_SIZE, - - mIN_UPD_SIZE, - mIN_SIZE_NonUpdHeapObject, - - sTD_HDR_SIZE, - pROF_HDR_SIZE, - gRAN_HDR_SIZE, - aRR_WORDS_HDR_SIZE, - aRR_PTRS_HDR_SIZE, - rESERVED_C_STACK_BYTES, - rESERVED_STACK_WORDS, - - sTD_ITBL_SIZE, - rET_ITBL_SIZE, - pROF_ITBL_SIZE, - gRAN_ITBL_SIZE, - tICKY_ITBL_SIZE, - - mAX_FAMILY_SIZE_FOR_VEC_RETURNS, - - uF_SIZE, - pROF_UF_SIZE, - gRAN_UF_SIZE, -- HWL - uF_RET, - uF_UPDATEE, - - mAX_Vanilla_REG, - mAX_Float_REG, - mAX_Double_REG, - mAX_Long_REG, - - mAX_Real_Vanilla_REG, - mAX_Real_Float_REG, - mAX_Real_Double_REG, - mAX_Real_Long_REG, - - mAX_INTLIKE, mIN_INTLIKE, - mAX_CHARLIKE, mIN_CHARLIKE, - - spRelToInt, - - dOUBLE_SIZE, - iNT64_SIZE, - wORD64_SIZE, - - wORD_SIZE, - wORD_SIZE_IN_BITS, - - bLOCK_SIZE, - bLOCK_SIZE_W, - - bITMAP_BITS_SHIFT, - ) where +module Constants (module Constants) where -- This magical #include brings in all the everybody-knows-these magic -- constants unfortunately, we need to be *explicit* about which one @@ -73,7 +12,7 @@ module Constants ( -- be in trouble. #include "HsVersions.h" -#include "../includes/config.h" +#include "../includes/ghcconfig.h" #include "../includes/MachRegs.h" #include "../includes/Constants.h" #include "../includes/MachDeps.h" @@ -107,47 +46,20 @@ mIN_SIZE_NonUpdHeapObject = (MIN_NONUPD_SIZE::Int) \end{code} \begin{code} -mIN_INTLIKE, mAX_INTLIKE :: Integer -- Only used to compare with (MachInt Integer) +mIN_INTLIKE, mAX_INTLIKE :: Int mIN_INTLIKE = MIN_INTLIKE mAX_INTLIKE = MAX_INTLIKE -mIN_CHARLIKE, mAX_CHARLIKE :: Int -- Only used to compare with (MachChar Int) +mIN_CHARLIKE, mAX_CHARLIKE :: Int mIN_CHARLIKE = MIN_CHARLIKE mAX_CHARLIKE = MAX_CHARLIKE \end{code} -A little function that abstracts the stack direction. Note that most -of the code generator is dependent on the stack direction anyway, so -changing this on its own spells certain doom. ToDo: remove? - -\begin{code} --- THIS IS DIRECTION SENSITIVE! - --- stack grows down, positive virtual offsets correspond to negative --- additions to the stack pointer. - -spRelToInt :: Int{-VirtualSpOffset-} -> Int{-VirtualSpOffset-} -> Int -spRelToInt sp off = sp - off -\end{code} - A section of code-generator-related MAGIC CONSTANTS. \begin{code} mAX_FAMILY_SIZE_FOR_VEC_RETURNS = (MAX_VECTORED_RTN::Int) -- pretty arbitrary -- If you change this, you may need to change runtimes/standard/Update.lhc - --- The update frame sizes -uF_SIZE = (STD_UF_SIZE::Int) - --- Same again, with profiling -pROF_UF_SIZE = (PROF_UF_SIZE::Int) - --- Same again, with gransim -gRAN_UF_SIZE = (GRAN_UF_SIZE::Int) - --- Offsets in an update frame. They don't change with profiling! -uF_RET = (UF_RET::Int) -uF_UPDATEE = (UF_UPDATEE::Int) \end{code} \begin{code} @@ -172,8 +84,6 @@ Closure header sizes. sTD_HDR_SIZE = (STD_HDR_SIZE :: Int) pROF_HDR_SIZE = (PROF_HDR_SIZE :: Int) gRAN_HDR_SIZE = (GRAN_HDR_SIZE :: Int) -aRR_WORDS_HDR_SIZE = (ARR_WORDS_HDR_SIZE :: Int) -aRR_PTRS_HDR_SIZE = (ARR_PTRS_HDR_SIZE :: Int) \end{code} Info Table sizes. @@ -189,8 +99,8 @@ tICKY_ITBL_SIZE = (TICKY_ITBL_SIZE :: Int) Size of a double in StgWords. \begin{code} -dOUBLE_SIZE = (SIZEOF_DOUBLE `quot` SIZEOF_HSWORD :: Int) -wORD64_SIZE = (8 `quot` SIZEOF_HSWORD :: Int) +dOUBLE_SIZE = SIZEOF_DOUBLE :: Int +wORD64_SIZE = 8 :: Int iNT64_SIZE = wORD64_SIZE \end{code} @@ -219,7 +129,7 @@ Size of a storage manager block (in bytes). \begin{code} bLOCK_SIZE = (BLOCK_SIZE :: Int) -bLOCK_SIZE_W = (bLOCK_SIZE `div` wORD_SIZE :: Int) +bLOCK_SIZE_W = (bLOCK_SIZE `quot` wORD_SIZE :: Int) \end{code} Number of bits to shift a bitfield left by in an info table. @@ -227,3 +137,10 @@ Number of bits to shift a bitfield left by in an info table. \begin{code} bITMAP_BITS_SHIFT = (BITMAP_BITS_SHIFT :: Int) \end{code} + +Constants derived from headers in ghc/includes, generated by the program +../includes/mkDerivedConstants.c. + +\begin{code} +#include "../includes/GHCConstants.h" +\end{code} diff --git a/ghc/compiler/main/DriverFlags.hs b/ghc/compiler/main/DriverFlags.hs index 766da42b8f..c09e43ad2d 100644 --- a/ghc/compiler/main/DriverFlags.hs +++ b/ghc/compiler/main/DriverFlags.hs @@ -14,7 +14,7 @@ module DriverFlags ( ) where #include "HsVersions.h" -#include "../includes/config.h" +#include "../includes/ghcconfig.h" import MkIface ( showIface ) import DriverState @@ -347,7 +347,7 @@ dynamic_flags = [ ------ Debugging ---------------------------------------------------- , ( "dstg-stats", NoArg (writeIORef v_StgStats True) ) - , ( "ddump-absC", NoArg (setDynFlag Opt_D_dump_absC) ) + , ( "ddump-cmm", NoArg (setDynFlag Opt_D_dump_cmm) ) , ( "ddump-asm", NoArg (setDynFlag Opt_D_dump_asm) ) , ( "ddump-cpranal", NoArg (setDynFlag Opt_D_dump_cpranal) ) , ( "ddump-deriv", NoArg (setDynFlag Opt_D_dump_deriv) ) @@ -357,7 +357,6 @@ dynamic_flags = [ , ( "ddump-inlinings", NoArg (setDynFlag Opt_D_dump_inlinings) ) , ( "ddump-occur-anal", NoArg (setDynFlag Opt_D_dump_occur_anal) ) , ( "ddump-parsed", NoArg (setDynFlag Opt_D_dump_parsed) ) - , ( "ddump-realC", NoArg (setDynFlag Opt_D_dump_realC) ) , ( "ddump-rn", NoArg (setDynFlag Opt_D_dump_rn) ) , ( "ddump-simpl", NoArg (setDynFlag Opt_D_dump_simpl) ) , ( "ddump-simpl-iterations", NoArg (setDynFlag Opt_D_dump_simpl_iterations) ) @@ -376,7 +375,7 @@ dynamic_flags = [ , ( "ddump-tc-trace", NoArg (setDynFlag Opt_D_dump_tc_trace) ) , ( "ddump-splices", NoArg (setDynFlag Opt_D_dump_splices) ) , ( "ddump-rn-stats", NoArg (setDynFlag Opt_D_dump_rn_stats) ) - , ( "ddump-stix", NoArg (setDynFlag Opt_D_dump_stix) ) + , ( "ddump-opt-cmm", NoArg (setDynFlag Opt_D_dump_opt_cmm) ) , ( "ddump-simpl-stats", NoArg (setDynFlag Opt_D_dump_simpl_stats) ) , ( "ddump-bcos", NoArg (setDynFlag Opt_D_dump_BCOs) ) , ( "dsource-stats", NoArg (setDynFlag Opt_D_source_stats) ) @@ -388,6 +387,7 @@ dynamic_flags = [ , ( "ddump-vect", NoArg (setDynFlag Opt_D_dump_vect) ) , ( "dcore-lint", NoArg (setDynFlag Opt_DoCoreLinting) ) , ( "dstg-lint", NoArg (setDynFlag Opt_DoStgLinting) ) + , ( "dcmm-lint", NoArg (setDynFlag Opt_DoCmmLinting) ) ------ Machine dependant (-m) stuff --------------------------- diff --git a/ghc/compiler/main/DriverPhases.hs b/ghc/compiler/main/DriverPhases.hs index c094663bcb..89a610021b 100644 --- a/ghc/compiler/main/DriverPhases.hs +++ b/ghc/compiler/main/DriverPhases.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverPhases.hs,v 1.28 2003/10/22 14:31:09 simonmar Exp $ +-- $Id: DriverPhases.hs,v 1.29 2004/08/13 13:06:57 simonmar Exp $ -- -- GHC Driver -- @@ -7,7 +7,7 @@ -- ----------------------------------------------------------------------------- -#include "../includes/config.h" +#include "../includes/ghcconfig.h" module DriverPhases ( Phase(..), @@ -54,6 +54,8 @@ data Phase | SplitAs | As | Ln + | CmmCpp -- pre-process Cmm source + | Cmm -- parse & compile Cmm code #ifdef ILX | Ilx2Il | Ilasm @@ -65,10 +67,13 @@ data Phase -- pipeline will stop at some point (see DriverPipeline.runPipeline). x `happensBefore` y | x `elem` haskell_pipe = y `elem` tail (dropWhile (/= x) haskell_pipe) + | x `elem` cmm_pipe = y `elem` tail (dropWhile (/= x) cmm_pipe) | x `elem` c_pipe = y `elem` tail (dropWhile (/= x) c_pipe) | otherwise = False -haskell_pipe = [Unlit,Cpp,HsPp,Hsc,HCc,Mangle,SplitMangle,As,SplitAs,Ln] +haskell_post_hsc = [HCc,Mangle,SplitMangle,As,SplitAs,Ln] +haskell_pipe = Unlit : Cpp : HsPp : Hsc : haskell_post_hsc +cmm_pipe = CmmCpp : Cmm : haskell_post_hsc c_pipe = [Cc,As,Ln] -- the first compilation phase for a given file is determined @@ -88,6 +93,8 @@ startPhase "raw_s" = Mangle startPhase "s" = As startPhase "S" = As startPhase "o" = Ln +startPhase "cmm" = CmmCpp +startPhase "cmmcpp" = Cmm startPhase _ = Ln -- all unknown file types -- the output suffix for a given phase is uniquely determined by @@ -103,13 +110,15 @@ phaseInputExt SplitMangle = "split_s" -- not really generated phaseInputExt As = "s" phaseInputExt SplitAs = "split_s" -- not really generated phaseInputExt Ln = "o" +phaseInputExt CmmCpp = "cmm" +phaseInputExt Cmm = "cmmcpp" #ifdef ILX phaseInputExt Ilx2Il = "ilx" phaseInputExt Ilasm = "il" #endif -haskellish_suffixes = [ "hs", "lhs", "hspp", "hscpp", "hcr", "hc", "raw_s" ] -haskellish_src_suffixes = [ "hs", "lhs", "hspp", "hscpp", "hcr"] +haskellish_suffixes = [ "hs", "lhs", "hspp", "hscpp", "hcr", "hc", "raw_s", "cmm" ] +haskellish_src_suffixes = [ "hs", "lhs", "hspp", "hscpp", "hcr", "cmm" ] cish_suffixes = [ "c", "cpp", "C", "cc", "cxx", "s", "S" ] extcoreish_suffixes = [ "hcr" ] haskellish_user_src_suffixes = [ "hs", "lhs" ] diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs index 072978a5ad..81c2f4698c 100644 --- a/ghc/compiler/main/DriverPipeline.hs +++ b/ghc/compiler/main/DriverPipeline.hs @@ -6,7 +6,7 @@ -- ----------------------------------------------------------------------------- -#include "../includes/config.h" +#include "../includes/ghcconfig.h" module DriverPipeline ( @@ -491,40 +491,8 @@ runPhase Cpp basename suff input_fn get_output_fn maybe_loc -- to the next phase of the pipeline. return (Just HsPp, maybe_loc, input_fn) else do - hscpp_opts <- getOpts opt_P - hs_src_cpp_opts <- readIORef v_Hs_source_cpp_opts - - cmdline_include_paths <- readIORef v_Include_paths - - pkg_include_dirs <- getPackageIncludePath [] - let include_paths = foldr (\ x xs -> "-I" : x : xs) [] - (cmdline_include_paths ++ pkg_include_dirs) - - verb <- getVerbFlag - (md_c_flags, _) <- machdepCCOpts - output_fn <- get_output_fn HsPp maybe_loc - - SysTools.runCpp ([SysTools.Option verb] - ++ map SysTools.Option include_paths - ++ map SysTools.Option hs_src_cpp_opts - ++ map SysTools.Option hscpp_opts - ++ map SysTools.Option md_c_flags - ++ [ SysTools.Option "-x" - , SysTools.Option "c" - , SysTools.Option input_fn - -- We hackily use Option instead of FileOption here, so that the file - -- name is not back-slashed on Windows. cpp is capable of - -- dealing with / in filenames, so it works fine. Furthermore - -- if we put in backslashes, cpp outputs #line directives - -- with *double* backslashes. And that in turn means that - -- our error messages get double backslashes in them. - -- In due course we should arrange that the lexer deals - -- with these \\ escapes properly. - , SysTools.Option "-o" - , SysTools.FileOption "" output_fn - ]) - + doCpp True{-raw-} False{-no CC opts-} input_fn output_fn return (Just HsPp, maybe_loc, output_fn) ------------------------------------------------------------------------------- @@ -661,6 +629,34 @@ runPhase Hsc basename suff input_fn get_output_fn _maybe_loc = do HscNothing -> return (Nothing, Just location, output_fn) _ -> return (Just next_phase, Just location, output_fn) +----------------------------------------------------------------------------- +-- Cmm phase + +runPhase CmmCpp basename suff input_fn get_output_fn maybe_loc + = do + output_fn <- get_output_fn Cmm maybe_loc + doCpp False{-not raw-} True{-include CC opts-} input_fn output_fn + return (Just Cmm, maybe_loc, output_fn) + +runPhase Cmm basename suff input_fn get_output_fn maybe_loc + = do + dyn_flags <- getDynFlags + hsc_lang <- hscMaybeAdjustLang (hscLang dyn_flags) + next_phase <- hscNextPhase hsc_lang + output_fn <- get_output_fn next_phase maybe_loc + + let dyn_flags' = dyn_flags { hscLang = hsc_lang, + hscOutName = output_fn, + hscStubCOutName = basename ++ "_stub.c", + hscStubHOutName = basename ++ "_stub.h", + extCoreName = basename ++ ".hcr" } + + ok <- hscCmmFile dyn_flags' input_fn + + when (not ok) $ throwDyn (PhaseFailed "cmm" (ExitFailure 1)) + + return (Just next_phase, maybe_loc, output_fn) + ----------------------------------------------------------------------------- -- Cc phase @@ -1150,6 +1146,50 @@ doMkDLL o_files dep_packages = do -- ----------------------------------------------------------------------------- -- Misc. +doCpp :: Bool -> Bool -> FilePath -> FilePath -> IO () +doCpp raw include_cc_opts input_fn output_fn = do + hscpp_opts <- getOpts opt_P + + cmdline_include_paths <- readIORef v_Include_paths + + pkg_include_dirs <- getPackageIncludePath [] + let include_paths = foldr (\ x xs -> "-I" : x : xs) [] + (cmdline_include_paths ++ pkg_include_dirs) + + verb <- getVerbFlag + + cc_opts <- if not include_cc_opts + then return [] + else do optc <- getOpts opt_c + (md_c_flags, _) <- machdepCCOpts + return (optc ++ md_c_flags) + + let cpp_prog args | raw = SysTools.runCpp args + | otherwise = SysTools.runCc (SysTools.Option "-E" : args) + + cpp_prog ([SysTools.Option verb] + ++ map SysTools.Option include_paths + ++ map SysTools.Option hsSourceCppOpts + ++ map SysTools.Option hscpp_opts + ++ map SysTools.Option cc_opts + ++ [ SysTools.Option "-x" + , SysTools.Option "c" + , SysTools.Option input_fn + -- We hackily use Option instead of FileOption here, so that the file + -- name is not back-slashed on Windows. cpp is capable of + -- dealing with / in filenames, so it works fine. Furthermore + -- if we put in backslashes, cpp outputs #line directives + -- with *double* backslashes. And that in turn means that + -- our error messages get double backslashes in them. + -- In due course we should arrange that the lexer deals + -- with these \\ escapes properly. + , SysTools.Option "-o" + , SysTools.FileOption "" output_fn + ]) + +-- ----------------------------------------------------------------------------- +-- Misc. + hscNextPhase :: HscLang -> IO Phase hscNextPhase hsc_lang = do split <- readIORef v_Split_object_files @@ -1171,8 +1211,6 @@ hscMaybeAdjustLang current_hsc_lang = do | current_hsc_lang == HscInterpreted = current_hsc_lang -- force -fvia-C if we are being asked for a .hc file | todo == StopBefore HCc || keep_hc = HscC - -- force -fvia-C when profiling or ticky-ticky is on - | opt_SccProfilingOn || opt_DoTickyProfiling = HscC -- otherwise, stick to the plan | otherwise = current_hsc_lang return hsc_lang diff --git a/ghc/compiler/main/DriverState.hs b/ghc/compiler/main/DriverState.hs index 543a487655..a34d4a101a 100644 --- a/ghc/compiler/main/DriverState.hs +++ b/ghc/compiler/main/DriverState.hs @@ -1,5 +1,4 @@ ----------------------------------------------------------------------------- --- $Id: DriverState.hs,v 1.104 2004/04/30 15:51:10 simonmar Exp $ -- -- Settings for the driver -- @@ -9,7 +8,7 @@ module DriverState where -#include "../includes/config.h" +#include "../includes/ghcconfig.h" #include "HsVersions.h" import ParsePkgConf ( loadPackageConfig ) @@ -71,14 +70,13 @@ isCompManagerMode _ = False ----------------------------------------------------------------------------- -- Global compilation flags --- Cpp-related flags -v_Hs_source_cpp_opts = global +-- Default CPP defines in Haskell source +hsSourceCppOpts = [ "-D__HASKELL1__="++cHaskell1Version , "-D__GLASGOW_HASKELL__="++cProjectVersionInt , "-D__HASKELL98__" , "-D__CONCURRENT_HASKELL__" ] -{-# NOINLINE v_Hs_source_cpp_opts #-} -- Keep output from intermediate phases diff --git a/ghc/compiler/main/DriverUtil.hs b/ghc/compiler/main/DriverUtil.hs index 80ca04bf18..b8796c1244 100644 --- a/ghc/compiler/main/DriverUtil.hs +++ b/ghc/compiler/main/DriverUtil.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverUtil.hs,v 1.42 2004/06/24 09:35:13 simonmar Exp $ +-- $Id: DriverUtil.hs,v 1.43 2004/08/13 13:07:02 simonmar Exp $ -- -- Utils for the driver -- @@ -19,7 +19,7 @@ module DriverUtil ( remove_spaces, escapeSpaces, ) where -#include "../includes/config.h" +#include "../includes/ghcconfig.h" #include "HsVersions.h" import Util diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs index f5f0b9b812..3a5364466a 100644 --- a/ghc/compiler/main/ErrUtils.lhs +++ b/ghc/compiler/main/ErrUtils.lhs @@ -178,9 +178,7 @@ dumpIfSet_core dflags flag hdr doc dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO () dumpIfSet_dyn dflags flag hdr doc | dopt flag dflags || verbosity dflags >= 4 - = if flag `elem` [Opt_D_dump_stix, Opt_D_dump_asm] - then printForC stdout (mkDumpDoc hdr doc) - else printDump (mkDumpDoc hdr doc) + = printDump (mkDumpDoc hdr doc) | otherwise = return () diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 8187bab03d..7b1a102571 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -6,7 +6,7 @@ \begin{code} module HscMain ( - HscResult(..), hscMain, newHscEnv, hscBufferFrontEnd + HscResult(..), hscMain, newHscEnv, hscCmmFile, hscBufferFrontEnd #ifdef GHCI , hscStmt, hscTcExpr, hscKcType, hscThing, , compileExpr @@ -57,6 +57,7 @@ import CoreToStg ( coreToStg ) import Name ( Name, NamedThing(..) ) import SimplStg ( stg2stg ) import CodeGen ( codeGen ) +import CmmParse ( parseCmmFile ) import CodeOutput ( codeOutput ) import CmdLineOpts @@ -449,6 +450,18 @@ hscBackEnd dflags } +hscCmmFile :: DynFlags -> FilePath -> IO Bool +hscCmmFile dflags filename = do + maybe_cmm <- parseCmmFile dflags filename + case maybe_cmm of + Nothing -> return False + Just cmm -> do + codeOutput dflags no_mod NoStubs noDependencies [cmm] + return True + where + no_mod = panic "hscCmmFile: no_mod" + + myParseModule dflags src_filename = do -------------------------- Parser ---------------- showPass dflags "Parser" diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs index cf25bde3b8..7a2ae0c67f 100644 --- a/ghc/compiler/main/Main.hs +++ b/ghc/compiler/main/Main.hs @@ -1,7 +1,7 @@ {-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-} ----------------------------------------------------------------------------- --- $Id: Main.hs,v 1.137 2004/08/12 13:10:40 simonmar Exp $ +-- $Id: Main.hs,v 1.138 2004/08/13 13:07:05 simonmar Exp $ -- -- GHC Driver program -- @@ -10,7 +10,7 @@ ----------------------------------------------------------------------------- -- with path so that ghc -M can find config.h -#include "../includes/config.h" +#include "../includes/ghcconfig.h" module Main (main) where @@ -168,14 +168,10 @@ main = -- by module basis, using only the -fvia-C and -fasm flags. If the global -- HscLang is not HscC or HscAsm, -fvia-C and -fasm have no effect. dyn_flags <- getDynFlags - build_tag <- readIORef v_Build_tag let lang = case mode of DoInteractive -> HscInterpreted DoEval _ -> HscInterpreted - _other | build_tag /= "" -> HscC - | otherwise -> hscLang dyn_flags - -- for ways other that the normal way, we must - -- compile via C. + _other -> hscLang dyn_flags setDynFlags (dyn_flags{ stgToDo = stg_todo, hscLang = lang, diff --git a/ghc/compiler/main/SysTools.lhs b/ghc/compiler/main/SysTools.lhs index da65fe2d02..fcd62defa7 100644 --- a/ghc/compiler/main/SysTools.lhs +++ b/ghc/compiler/main/SysTools.lhs @@ -84,7 +84,7 @@ import IO ( try, catch, import Directory ( doesFileExist, removeFile ) import List ( partition ) -#include "../includes/config.h" +#include "../includes/ghcconfig.h" -- GHC <= 4.08 didn't have rawSystem, and runs into problems with long command -- lines on mingw32, so we disallow it now. diff --git a/ghc/compiler/nativeGen/AbsCStixGen.lhs b/ghc/compiler/nativeGen/AbsCStixGen.lhs deleted file mode 100644 index 4a53f1437f..0000000000 --- a/ghc/compiler/nativeGen/AbsCStixGen.lhs +++ /dev/null @@ -1,694 +0,0 @@ -% -% (c) The AQUA Project, Glasgow University, 1993-1998 -% - -\begin{code} -module AbsCStixGen ( genCodeAbstractC ) where - -#include "HsVersions.h" - -import Ratio ( Rational ) - -import AbsCSyn -import Stix -import MachMisc - -import AbsCUtils ( getAmodeRep, mixedTypeLocn, - nonemptyAbsC, mkAbsCStmts - ) -import PprAbsC ( dumpRealC ) -import SMRep ( retItblSize ) -import CLabel ( CLabel, mkReturnInfoLabel, mkReturnPtLabel, - mkClosureTblLabel, mkClosureLabel, - labelDynamic, mkSplitMarkerLabel ) -import ClosureInfo -import Literal ( Literal(..), word2IntLit ) -import StgSyn ( StgOp(..) ) -import MachOp ( MachOp(..), resultRepOfMachOp ) -import PrimRep ( isFloatingRep, is64BitRep, - PrimRep(..), getPrimRepSizeInBytes ) -import StixMacro ( macroCode, checkCode ) -import StixPrim ( foreignCallCode, amodeToStix, amodeToStix' ) -import Outputable ( pprPanic, ppr ) -import UniqSupply ( returnUs, thenUs, mapUs, getUniqueUs, UniqSM ) -import Util ( naturalMergeSortLe ) -import Panic ( panic ) -import TyCon ( tyConDataCons ) -import Name ( NamedThing(..) ) -import CmdLineOpts ( opt_EnsureSplittableC ) -import Outputable ( assertPanic ) - -import Char ( ord ) - --- DEBUGGING ONLY ---import TRACE ( trace ) ---import Outputable ( showSDoc ) ---import MachOp ( pprMachOp ) - -#include "nativeGen/NCG.h" -\end{code} - -For each independent chunk of AbstractC code, we generate a list of -@StixTree@s, where each tree corresponds to a single Stix instruction. -We leave the chunks separated so that register allocation can be -performed locally within the chunk. - -\begin{code} -genCodeAbstractC :: AbstractC -> UniqSM [StixStmt] - -genCodeAbstractC absC - = gentopcode absC - where - a2stix = amodeToStix - a2stix' = amodeToStix' - volsaves = volatileSaves - volrestores = volatileRestores - -- real code follows... --------- -\end{code} - -Here we handle top-level things, like @CCodeBlock@s and -@CClosureInfoTable@s. - -\begin{code} - {- - genCodeTopAbsC - :: AbstractC - -> UniqSM [StixTree] - -} - - gentopcode (CCodeBlock lbl absC) - = gencode absC `thenUs` \ code -> - returnUs (StSegment TextSegment : StFunBegin lbl : code [StFunEnd lbl]) - - gentopcode stmt@(CStaticClosure lbl closure_info _ _) - = genCodeStaticClosure stmt `thenUs` \ code -> - returnUs ( StSegment DataSegment - : StLabel lbl : code [] - ) - - gentopcode stmt@(CRetVector lbl amodes srt liveness) - = returnUs ( StSegment TextSegment - : StData PtrRep table - : StLabel lbl - : [] - ) - where - table = map amodeToStix (mkVecInfoTable amodes srt liveness) - - gentopcode stmt@(CRetDirect uniq absC srt liveness) - = gencode absC `thenUs` \ code -> - returnUs ( StSegment TextSegment - : StData PtrRep table - : StLabel info_lbl - : StLabel ret_lbl - : code []) - where - info_lbl = mkReturnInfoLabel uniq - ret_lbl = mkReturnPtLabel uniq - table = map amodeToStix (mkRetInfoTable ret_lbl srt liveness) - - gentopcode stmt@(CClosureInfoAndCode cl_info entry) - = gencode entry `thenUs` \ slow_code -> - returnUs ( StSegment TextSegment - : StData PtrRep table - : StLabel info_lbl - : StFunBegin entry_lbl - : slow_code [StFunEnd entry_lbl]) - where - entry_lbl = entryLabelFromCI cl_info - info_lbl = infoTableLabelFromCI cl_info - table = map amodeToStix (mkInfoTable cl_info) - - gentopcode stmt@(CSRT lbl closures) - = returnUs [ StSegment TextSegment - , StLabel lbl - , StData DataPtrRep (map mk_StCLbl_for_SRT closures) - ] - where - mk_StCLbl_for_SRT :: CLabel -> StixExpr - mk_StCLbl_for_SRT label - | labelDynamic label - = StIndex Int8Rep (StCLbl label) (StInt 1) - | otherwise - = StCLbl label - - gentopcode stmt@(CBitmap l@(Liveness lbl size mask)) - = returnUs - [ StSegment TextSegment - , StLabel lbl - , StData WordRep (map StInt (toInteger size : map toInteger mask)) - ] - - gentopcode stmt@(CSRTDesc lbl srt_lbl off len bitmap) - = returnUs - [ StSegment TextSegment - , StLabel lbl - , StData WordRep ( - StIndex PtrRep (StCLbl srt_lbl) (StInt (toInteger off)) : - map StInt (toInteger len : map toInteger bitmap) - ) - ] - - gentopcode stmt@(CClosureTbl tycon) - = returnUs [ StSegment TextSegment - , StLabel (mkClosureTblLabel tycon) - , StData DataPtrRep (map (StCLbl . mkClosureLabel . getName) - (tyConDataCons tycon) ) - ] - - gentopcode stmt@(CModuleInitBlock plain_lbl lbl absC) - = gencode absC `thenUs` \ code -> - getUniqLabelNCG `thenUs` \ tmp_lbl -> - getUniqLabelNCG `thenUs` \ flag_lbl -> - returnUs ( StSegment DataSegment - : StLabel flag_lbl - : StData IntRep [StInt 0] - : StSegment TextSegment - : StLabel plain_lbl - : StJump NoDestInfo (StCLbl lbl) - : StLabel lbl - : StCondJump tmp_lbl (StMachOp MO_Nat_Ne - [StInd IntRep (StCLbl flag_lbl), - StInt 0]) - : StAssignMem IntRep (StCLbl flag_lbl) (StInt 1) - : code - [ StLabel tmp_lbl - , StAssignReg PtrRep stgSp - (StIndex PtrRep (StReg stgSp) (StInt (-1))) - , StJump NoDestInfo (StInd WordRep (StReg stgSp)) - ]) - - gentopcode absC - = gencode absC `thenUs` \ code -> - returnUs (StSegment TextSegment : code []) -\end{code} - -\begin{code} - {- - genCodeStaticClosure - :: AbstractC - -> UniqSM StixTreeList - -} - genCodeStaticClosure (CStaticClosure lbl cl_info cost_centre amodes) - = returnUs (\xs -> table ++ xs) - where - table = StData PtrRep [StCLbl (infoTableLabelFromCI cl_info)] : - foldr do_one_amode [] amodes - - do_one_amode amode rest - | rep == VoidRep = rest - | otherwise = StData (promote_to_word rep) [a2stix amode] : rest - where - rep = getAmodeRep amode - - -- We need to promote any item smaller than a word to a word - promote_to_word pk - | getPrimRepSizeInBytes pk >= getPrimRepSizeInBytes IntRep = pk - | otherwise = IntRep -\end{code} - -Now the individual AbstractC statements. - -\begin{code} - {- - gencode - :: AbstractC - -> UniqSM StixTreeList - -} -\end{code} - -@AbsCNop@s just disappear. - -\begin{code} - - gencode AbsCNop = returnUs id - -\end{code} - -Split markers just insert a __stg_split_marker, which is caught by the -split-mangler later on and used to split the assembly into chunks. - -\begin{code} - - gencode CSplitMarker - | opt_EnsureSplittableC = returnUs (\xs -> StLabel mkSplitMarkerLabel : xs) - | otherwise = returnUs id - -\end{code} - -AbstractC instruction sequences are handled individually, and the -resulting StixTreeLists are joined together. - -\begin{code} - - gencode (AbsCStmts c1 c2) - = gencode c1 `thenUs` \ b1 -> - gencode c2 `thenUs` \ b2 -> - returnUs (b1 . b2) - - gencode (CSequential stuff) - = foo stuff - where - foo [] = returnUs id - foo (s:ss) = gencode s `thenUs` \ stix -> - foo ss `thenUs` \ stixes -> - returnUs (stix . stixes) - -\end{code} - -Initialising closure headers in the heap...a fairly complex ordeal if -done properly. For now, we just set the info pointer, but we should -really take a peek at the flags to determine whether or not there are -other things to be done (setting cost centres, age headers, global -addresses, etc.) - -\begin{code} - - gencode (CInitHdr cl_info reg_rel _ _) - = let - lhs = a2stix reg_rel - lbl = infoTableLabelFromCI cl_info - in - returnUs (\xs -> StAssignMem PtrRep lhs (StCLbl lbl) : xs) - -\end{code} - -Heap/Stack Checks. - -\begin{code} - - gencode (CCheck macro args assts) - = gencode assts `thenUs` \assts_stix -> - checkCode macro args assts_stix - -\end{code} - -Assignment, the curse of von Neumann, is the center of the code we -produce. In most cases, the type of the assignment is determined -by the type of the destination. However, when the destination can -have mixed types, the type of the assignment is ``StgWord'' (we use -PtrRep for lack of anything better). Think: do we also want a cast -of the source? Be careful about floats/doubles. - -\begin{code} - - gencode (CAssign lhs rhs) - | lhs_rep == VoidRep - = returnUs id - | otherwise - = let -- This is a Hack. Should be cleaned up. - -- JRS, 10 Dec 01 - pk' | ncg_target_is_32bit && is64BitRep lhs_rep - = lhs_rep - | otherwise - = if mixedTypeLocn lhs && not (isFloatingRep lhs_rep) - then IntRep - else lhs_rep - lhs' = a2stix lhs - rhs' = a2stix' rhs - in - returnUs (\xs -> mkStAssign pk' lhs' rhs' : xs) - where - lhs_rep = getAmodeRep lhs - -\end{code} - -Unconditional jumps, including the special ``enter closure'' operation. -Note that the new entry convention requires that we load the InfoPtr (R2) -with the address of the info table before jumping to the entry code for Node. - -For a vectored return, we must subtract the size of the info table to -get at the return vector. This depends on the size of the info table, -which varies depending on whether we're profiling etc. - -\begin{code} - - gencode (CJump dest) - = returnUs (\xs -> StJump NoDestInfo (a2stix dest) : xs) - - gencode (CFallThrough (CLbl lbl _)) - = returnUs (\xs -> StFallThrough lbl : xs) - - gencode (CReturn dest DirectReturn) - = returnUs (\xs -> StJump NoDestInfo (a2stix dest) : xs) - - gencode (CReturn table (StaticVectoredReturn n)) - = returnUs (\xs -> StJump NoDestInfo dest : xs) - where - dest = StInd PtrRep (StIndex PtrRep (a2stix table) - (StInt (toInteger (-n-retItblSize-1)))) - - gencode (CReturn table (DynamicVectoredReturn am)) - = returnUs (\xs -> StJump NoDestInfo dest : xs) - where - dest = StInd PtrRep (StIndex PtrRep (a2stix table) dyn_off) - dyn_off = StMachOp MO_Nat_Sub [StMachOp MO_NatS_Neg [a2stix am], - StInt (toInteger (retItblSize+1))] - -\end{code} - -Now the PrimOps, some of which may need caller-saves register wrappers. - -\begin{code} - gencode (COpStmt results (StgFCallOp fcall _) args vols) - = ASSERT( null vols ) - foreignCallCode (nonVoid results) fcall (nonVoid args) - - gencode (COpStmt results (StgPrimOp op) args vols) - = panic "AbsCStixGen.gencode: un-translated PrimOp" - - gencode (CMachOpStmt res mop args vols) - = returnUs (\xs -> mkStAssign (resultRepOfMachOp mop) (a2stix res) - (StMachOp mop (map a2stix args)) - : xs - ) -\end{code} - -Now the dreaded conditional jump. - -Now the if statement. Almost *all* flow of control are of this form. -@ - if (am==lit) { absC } else { absCdef } -@ - => -@ - IF am = lit GOTO l1: - absC - jump l2: - l1: - absCdef - l2: -@ - -\begin{code} - - gencode (CSwitch discrim alts deflt) - = case alts of - [] -> gencode deflt - - [(tag,alt_code)] -> case maybe_empty_deflt of - Nothing -> gencode alt_code - Just dc -> mkIfThenElse discrim tag alt_code dc - - [(tag1@(MachInt i1), alt_code1), - (tag2@(MachInt i2), alt_code2)] - | deflt_is_empty && i1 == 0 && i2 == 1 - -> mkIfThenElse discrim tag1 alt_code1 alt_code2 - | deflt_is_empty && i1 == 1 && i2 == 0 - -> mkIfThenElse discrim tag2 alt_code2 alt_code1 - - -- If the @discrim@ is simple, then this unfolding is safe. - other | simple_discrim -> mkSimpleSwitches discrim alts deflt - - -- Otherwise, we need to do a bit of work. - other -> getUniqueUs `thenUs` \ u -> - gencode (AbsCStmts - (CAssign (CTemp u pk) discrim) - (CSwitch (CTemp u pk) alts deflt)) - - where - maybe_empty_deflt = nonemptyAbsC deflt - deflt_is_empty = case maybe_empty_deflt of - Nothing -> True - Just _ -> False - - pk = getAmodeRep discrim - - simple_discrim = case discrim of - CReg _ -> True - CTemp _ _ -> True - other -> False -\end{code} - - - -Finally, all of the disgusting AbstractC macros. - -\begin{code} - - gencode (CMacroStmt macro args) = macroCode macro (map amodeToStix args) - - gencode (CCallProfCtrMacro macro _) - = returnUs (\xs -> StComment macro : xs) - - gencode (CCallProfCCMacro macro _) - = returnUs (\xs -> StComment macro : xs) - - gencode CCallTypedef{} = returnUs id - - gencode other - = pprPanic "AbsCStixGen.gencode" (dumpRealC other) - - nonVoid = filter ((/= VoidRep) . getAmodeRep) -\end{code} - -Here, we generate a jump table if there are more than four (integer) -alternatives and the jump table occupancy is greater than 50%. -Otherwise, we generate a binary comparison tree. (Perhaps this could -be tuned.) - -\begin{code} - - intTag :: Literal -> Integer - intTag (MachChar c) = toInteger (ord c) - intTag (MachInt i) = i - intTag (MachWord w) = intTag (word2IntLit (MachWord w)) - intTag _ = panic "intTag" - - fltTag :: Literal -> Rational - - fltTag (MachFloat f) = f - fltTag (MachDouble d) = d - fltTag x = pprPanic "fltTag" (ppr x) - - {- - mkSimpleSwitches - :: CAddrMode -> [(Literal,AbstractC)] -> AbstractC - -> UniqSM StixTreeList - -} - mkSimpleSwitches am alts absC - = getUniqLabelNCG `thenUs` \ udlbl -> - getUniqLabelNCG `thenUs` \ ujlbl -> - let am' = a2stix am - joinedAlts = map (\ (tag,code) -> (tag, mkJoin code ujlbl)) alts - sortedAlts = naturalMergeSortLe leAlt joinedAlts - -- naturalMergeSortLe, because we often get sorted alts to begin with - - lowTag = intTag (fst (head sortedAlts)) - highTag = intTag (fst (last sortedAlts)) - - -- lowest and highest possible values the discriminant could take - lowest = if floating then targetMinDouble else targetMinInt - highest = if floating then targetMaxDouble else targetMaxInt - in - ( - if not floating && choices > 4 - && highTag - lowTag < toInteger (2 * choices) - then - mkJumpTable am' sortedAlts lowTag highTag udlbl - else - mkBinaryTree am' floating sortedAlts choices lowest highest udlbl - ) - `thenUs` \ alt_code -> - gencode absC `thenUs` \ dflt_code -> - - returnUs (\xs -> alt_code (StLabel udlbl : dflt_code (StLabel ujlbl : xs))) - - where - floating = isFloatingRep (getAmodeRep am) - choices = length alts - - (x@(MachChar _),_) `leAlt` (y,_) = intTag x <= intTag y - (x@(MachInt _), _) `leAlt` (y,_) = intTag x <= intTag y - (x@(MachWord _), _) `leAlt` (y,_) = intTag x <= intTag y - (x,_) `leAlt` (y,_) = fltTag x <= fltTag y - -\end{code} - -We use jump tables when doing an integer switch on a relatively dense -list of alternatives. We expect to be given a list of alternatives, -sorted by tag, and a range of values for which we are to generate a -table. Of course, the tags of the alternatives should lie within the -indicated range. The alternatives need not cover the range; a default -target is provided for the missing alternatives. - -If a join is necessary after the switch, the alternatives should -already finish with a jump to the join point. - -\begin{code} - {- - mkJumpTable - :: StixTree -- discriminant - -> [(Literal, AbstractC)] -- alternatives - -> Integer -- low tag - -> Integer -- high tag - -> CLabel -- default label - -> UniqSM StixTreeList - -} - - mkJumpTable am alts lowTag highTag dflt - = getUniqLabelNCG `thenUs` \ utlbl -> - mapUs genLabel alts `thenUs` \ branches -> - let cjmpLo = StCondJump dflt (StMachOp MO_NatS_Lt [am, StInt (toInteger lowTag)]) - cjmpHi = StCondJump dflt (StMachOp MO_NatS_Gt [am, StInt (toInteger highTag)]) - - offset = StMachOp MO_Nat_Sub [am, StInt lowTag] - dsts = DestInfo (dflt : map fst branches) - - jump = StJump dsts (StInd PtrRep (StIndex PtrRep (StCLbl utlbl) offset)) - tlbl = StLabel utlbl - table = StData PtrRep (mkTable branches [lowTag..highTag] []) - in - mapUs mkBranch branches `thenUs` \ alts -> - - returnUs (\xs -> cjmpLo : cjmpHi : jump : - StSegment DataSegment : tlbl : table : - StSegment TextSegment : foldr1 (.) alts xs) - - where - genLabel x = getUniqLabelNCG `thenUs` \ lbl -> returnUs (lbl, x) - - mkBranch (lbl,(_,alt)) = - gencode alt `thenUs` \ alt_code -> - returnUs (\xs -> StLabel lbl : alt_code xs) - - mkTable _ [] tbl = reverse tbl - mkTable [] (x:xs) tbl = mkTable [] xs (StCLbl dflt : tbl) - mkTable alts@((lbl,(tag,_)):rest) (x:xs) tbl - | intTag tag == x = mkTable rest xs (StCLbl lbl : tbl) - | otherwise = mkTable alts xs (StCLbl dflt : tbl) - -\end{code} - -We generate binary comparison trees when a jump table is inappropriate. -We expect to be given a list of alternatives, sorted by tag, and for -convenience, the length of the alternative list. We recursively break -the list in half and do a comparison on the first tag of the second half -of the list. (Odd lists are broken so that the second half of the list -is longer.) We can handle either integer or floating kind alternatives, -so long as they are not mixed. (We assume that the type of the discriminant -determines the type of the alternatives.) - -As with the jump table approach, if a join is necessary after the switch, the -alternatives should already finish with a jump to the join point. - -\begin{code} - {- - mkBinaryTree - :: StixTree -- discriminant - -> Bool -- floating point? - -> [(Literal, AbstractC)] -- alternatives - -> Int -- number of choices - -> Literal -- low tag - -> Literal -- high tag - -> CLabel -- default code label - -> UniqSM StixTreeList - -} - - mkBinaryTree am floating [(tag,alt)] _ lowTag highTag udlbl - | rangeOfOne = gencode alt - | otherwise - = let tag' = a2stix (CLit tag) - cmpOp = if floating then MO_Dbl_Ne else MO_Nat_Ne - test = StMachOp cmpOp [am, tag'] - cjmp = StCondJump udlbl test - in - gencode alt `thenUs` \ alt_code -> - returnUs (\xs -> cjmp : alt_code xs) - - where - rangeOfOne = not floating && intTag lowTag + 1 >= intTag highTag - -- When there is only one possible tag left in range, we skip the comparison - - mkBinaryTree am floating alts choices lowTag highTag udlbl - = getUniqLabelNCG `thenUs` \ uhlbl -> - let tag' = a2stix (CLit splitTag) - cmpOp = if floating then MO_Dbl_Ge else MO_NatS_Ge - test = StMachOp cmpOp [am, tag'] - cjmp = StCondJump uhlbl test - in - mkBinaryTree am floating alts_lo half lowTag splitTag udlbl - `thenUs` \ lo_code -> - mkBinaryTree am floating alts_hi (choices - half) splitTag highTag udlbl - `thenUs` \ hi_code -> - - returnUs (\xs -> cjmp : lo_code (StLabel uhlbl : hi_code xs)) - - where - half = choices `div` 2 - (alts_lo, alts_hi) = splitAt half alts - splitTag = fst (head alts_hi) - -\end{code} - -\begin{code} - {- - mkIfThenElse - :: CAddrMode -- discriminant - -> Literal -- tag - -> AbstractC -- if-part - -> AbstractC -- else-part - -> UniqSM StixTreeList - -} - - mkIfThenElse discrim tag alt deflt - = getUniqLabelNCG `thenUs` \ ujlbl -> - getUniqLabelNCG `thenUs` \ utlbl -> - let discrim' = a2stix discrim - tag' = a2stix (CLit tag) - cmpOp = if (isFloatingRep (getAmodeRep discrim)) then MO_Dbl_Ne else MO_Nat_Ne - test = StMachOp cmpOp [discrim', tag'] - cjmp = StCondJump utlbl test - dest = StLabel utlbl - join = StLabel ujlbl - in - gencode (mkJoin alt ujlbl) `thenUs` \ alt_code -> - gencode deflt `thenUs` \ dflt_code -> - returnUs (\xs -> cjmp : alt_code (dest : dflt_code (join : xs))) - - -mkJoin :: AbstractC -> CLabel -> AbstractC -mkJoin code lbl - | mightFallThrough code = mkAbsCStmts code (CJump (CLbl lbl PtrRep)) - | otherwise = code -\end{code} - -%--------------------------------------------------------------------------- - -This answers the question: Can the code fall through to the next -line(s) of code? This errs towards saying True if it can't choose, -because it is used for eliminating needless jumps. In other words, if -you might possibly {\em not} jump, then say yes to falling through. - -\begin{code} -mightFallThrough :: AbstractC -> Bool - -mightFallThrough absC = ft absC True - where - ft AbsCNop if_empty = if_empty - - ft (CJump _) if_empty = False - ft (CReturn _ _) if_empty = False - ft (CSwitch _ alts deflt) if_empty - = ft deflt if_empty || - or [ft alt if_empty | (_,alt) <- alts] - - ft (AbsCStmts c1 c2) if_empty = ft c2 (ft c1 if_empty) - ft _ if_empty = if_empty - -{- Old algorithm, which called nonemptyAbsC for every subexpression! ========= -fallThroughAbsC (AbsCStmts c1 c2) - = case nonemptyAbsC c2 of - Nothing -> fallThroughAbsC c1 - Just x -> fallThroughAbsC x -fallThroughAbsC (CJump _) = False -fallThroughAbsC (CReturn _ _) = False -fallThroughAbsC (CSwitch _ choices deflt) - = (not (isEmptyAbsC deflt) && fallThroughAbsC deflt) - || or (map (fallThroughAbsC . snd) choices) -fallThroughAbsC other = True - -isEmptyAbsC :: AbstractC -> Bool -isEmptyAbsC = not . maybeToBool . nonemptyAbsC -================= End of old, quadratic, algorithm -} -\end{code} diff --git a/ghc/compiler/nativeGen/AsmCodeGen.lhs b/ghc/compiler/nativeGen/AsmCodeGen.lhs index 6510b41886..b2fcb6c653 100644 --- a/ghc/compiler/nativeGen/AsmCodeGen.lhs +++ b/ghc/compiler/nativeGen/AsmCodeGen.lhs @@ -1,6 +1,10 @@ -% -% (c) The AQUA Project, Glasgow University, 1993-1998 -% +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow 1993-2004 +-- +-- This is the top-level module in the native code generator. +-- +-- ----------------------------------------------------------------------------- \begin{code} module AsmCodeGen ( nativeCodeGen ) where @@ -8,34 +12,35 @@ module AsmCodeGen ( nativeCodeGen ) where #include "HsVersions.h" #include "NCG.h" -import MachMisc +import MachInstrs import MachRegs -import MachCode +import MachCodeGen import PprMach +import RegisterAlloc +import RegAllocInfo ( jumpDests ) +import NCGMonad + +import Cmm +import PprCmm ( pprStmt, pprCmms ) +import MachOp +import CLabel ( CLabel, mkSplitMarkerLabel ) +#if powerpc_TARGET_ARCH +import CLabel ( mkRtsCodeLabel ) +#endif -import AbsCStixGen ( genCodeAbstractC ) -import AbsCSyn ( AbstractC, MagicId(..) ) -import AbsCUtils ( mkAbsCStmtList, magicIdPrimRep ) -import AsmRegAlloc ( runRegAllocate ) -import MachOp ( MachOp(..), isCommutableMachOp, isComparisonMachOp ) -import RegAllocInfo ( findReservedRegs ) -import Stix ( StixReg(..), StixStmt(..), StixExpr(..), StixVReg(..), - pprStixStmts, pprStixStmt, - stixStmt_CountTempUses, stixStmt_Subst, - liftStrings, - initNat, - mkNatM_State, - uniqOfNatM_State, deltaOfNatM_State, - importsOfNatM_State ) -import UniqSupply ( returnUs, thenUs, initUs, - UniqSM, UniqSupply, - lazyMapUs ) -import MachMisc ( IF_ARCH_i386(i386_insert_ffrees,) ) +import UniqFM +import Unique ( Unique, getUnique ) +import UniqSupply +import FastTypes #if darwin_TARGET_OS import PprMach ( pprDyldSymbolStub ) import List ( group, sort ) #endif +import ErrUtils ( dumpIfSet_dyn ) +import CmdLineOpts ( DynFlags, DynFlag(..), dopt, opt_Static, + opt_EnsureSplittableC ) +import Digraph import qualified Pretty import Outputable import FastString @@ -46,377 +51,775 @@ import FastString #ifdef NCG_DEBUG import List ( intersperse ) #endif -\end{code} -The 96/03 native-code generator has machine-independent and -machine-dependent modules (those \tr{#include}'ing \tr{NCG.h}). +import DATA_INT +import DATA_WORD +import DATA_BITS +import GLAEXTS -This module (@AsmCodeGen@) is the top-level machine-independent -module. It uses @AbsCStixGen.genCodeAbstractC@ to produce @StixTree@s -(defined in module @Stix@), using support code from @StixPrim@ -(primitive operations), @StixMacro@ (Abstract C macros), and -@StixInteger@ (GMP arbitrary-precision operations). +{- +The native-code generator has machine-independent and +machine-dependent modules. -Before entering machine-dependent land, we do some machine-independent -@genericOpt@imisations (defined below) on the @StixTree@s. +This module ("AsmCodeGen") is the top-level machine-independent +module. Before entering machine-dependent land, we do some +machine-independent optimisations (defined below) on the +'CmmStmts's. -We convert to the machine-specific @Instr@ datatype with -@stmt2Instrs@, assuming an ``infinite'' supply of registers. We then -use a machine-independent register allocator (@runRegAllocate@) to -rejoin reality. Obviously, @runRegAllocate@ has machine-specific -helper functions (see about @RegAllocInfo@ below). +We convert to the machine-specific 'Instr' datatype with +'cmmCodeGen', assuming an infinite supply of registers. We then use +a machine-independent register allocator ('regAlloc') to rejoin +reality. Obviously, 'regAlloc' has machine-specific helper +functions (see about "RegAllocInfo" below). + +Finally, we order the basic blocks of the function so as to minimise +the number of jumps between blocks, by utilising fallthrough wherever +possible. The machine-dependent bits break down as follows: -\begin{description} -\item[@MachRegs@:] Everything about the target platform's machine + + * ["MachRegs"] Everything about the target platform's machine registers (and immediate operands, and addresses, which tend to intermingle/interact with registers). -\item[@MachMisc@:] Includes the @Instr@ datatype (possibly should + * ["MachInstrs"] Includes the 'Instr' datatype (possibly should have a module of its own), plus a miscellany of other things - (e.g., @targetDoubleSize@, @smStablePtrTable@, ...) + (e.g., 'targetDoubleSize', 'smStablePtrTable', ...) -\item[@MachCode@:] @stmt2Instrs@ is where @Stix@ stuff turns into + * ["MachCodeGen"] is where 'Cmm' stuff turns into machine instructions. -\item[@PprMach@:] @pprInstr@ turns an @Instr@ into text (well, really - an @Doc@). + * ["PprMach"] 'pprInstr' turns an 'Instr' into text (well, really + a 'Doc'). -\item[@RegAllocInfo@:] In the register allocator, we manipulate - @MRegsState@s, which are @BitSet@s, one bit per machine register. + * ["RegAllocInfo"] In the register allocator, we manipulate + 'MRegsState's, which are 'BitSet's, one bit per machine register. When we want to say something about a specific machine register (e.g., ``it gets clobbered by this instruction''), we set/unset - its bit. Obviously, we do this @BitSet@ thing for efficiency + its bit. Obviously, we do this 'BitSet' thing for efficiency reasons. - The @RegAllocInfo@ module collects together the machine-specific + The 'RegAllocInfo' module collects together the machine-specific info needed to do register allocation. -\end{description} -So, here we go: + * ["RegisterAlloc"] The (machine-independent) register allocator. +-} -\begin{code} -nativeCodeGen :: AbstractC -> UniqSupply -> (SDoc, Pretty.Doc) -nativeCodeGen absC us - = let absCstmts = mkAbsCStmtList absC - (results, us1) = initUs us (lazyMapUs absCtoNat absCstmts) - stix_sdocs = [ stix | (stix, insn, imports) <- results ] - insn_sdocs = [ insn | (stix, insn, imports) <- results ] - imports = [ imports | (stix, insn, imports) <- results ] +-- ----------------------------------------------------------------------------- +-- Top-level of the native codegen - insn_sdoc = my_vcat insn_sdocs IF_OS_darwin(Pretty.$$ dyld_stubs,) - stix_sdoc = vcat stix_sdocs +-- NB. We *lazilly* compile each block of code for space reasons. -#if darwin_TARGET_OS - -- Generate "symbol stubs" for all external symbols that might - -- come from a dynamic library. +nativeCodeGen :: DynFlags -> [Cmm] -> UniqSupply -> IO Pretty.Doc +nativeCodeGen dflags cmms us + | not opt_Static + = panic "NCG does not handle dynamic libraries right now" + -- ToDo: MachCodeGen used to have derefDLL function which expanded + -- dynamic CLabels (labelDynamic lbl == True) into the appropriate + -- dereferences. This should be done in the pre-NCG cmmToCmm pass instead. + -- It doesn't apply to static data, of course. There are hacks so that + -- the RTS knows what to do for references to closures in a DLL in SRTs, + -- and we never generate a reference to a closure in another DLL in a + -- static constructor. - dyld_stubs = Pretty.vcat $ map pprDyldSymbolStub $ - map head $ group $ sort $ concat imports -#endif + | otherwise + = let ((ppr_cmms, insn_sdoc, imports), _) = initUs us $ + cgCmm (concat (map add_split cmms)) -# ifdef NCG_DEBUG - my_trace m x = trace m x - my_vcat sds = Pretty.vcat ( - intersperse ( - Pretty.char ' ' - Pretty.$$ Pretty.ptext SLIT("# ___ncg_debug_marker") - Pretty.$$ Pretty.char ' ' - ) - sds - ) -# else - my_vcat sds = Pretty.vcat sds - my_trace m x = x -# endif - in - my_trace "nativeGen: begin" - (stix_sdoc, insn_sdoc) - - -absCtoNat :: AbstractC -> UniqSM (SDoc, Pretty.Doc, [FastString]) -absCtoNat absC - = _scc_ "genCodeAbstractC" genCodeAbstractC absC `thenUs` \ stixRaw -> - _scc_ "genericOpt" genericOpt stixRaw `bind` \ stixOpt -> - _scc_ "liftStrings" liftStrings stixOpt `thenUs` \ stixLifted -> - _scc_ "genMachCode" genMachCode stixLifted `thenUs` \ (pre_regalloc, imports) -> - _scc_ "regAlloc" regAlloc pre_regalloc `bind` \ almost_final -> - _scc_ "x86fp_kludge" x86fp_kludge almost_final `bind` \ final_mach_code -> - _scc_ "vcat" Pretty.vcat (map pprInstr final_mach_code) `bind` \ final_sdoc -> - _scc_ "pprStixTrees" pprStixStmts stixOpt `bind` \ stix_sdoc -> - returnUs ({-\_ -> Pretty.vcat (map pprInstr almost_final),-} - stix_sdoc, final_sdoc, imports) - where - bind f x = x f + cgCmm :: [CmmTop] -> UniqSM (Cmm, Pretty.Doc, [(Bool, CLabel)]) + cgCmm tops = + lazyMapUs (cmmNativeGen dflags) tops `thenUs` \ results -> + let (cmms,docs,imps) = unzip3 results in + returnUs (Cmm cmms, my_vcat docs, concat imps) + in do + dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm" (pprCmms [ppr_cmms]) + return (insn_sdoc Pretty.$$ dyld_stubs imports) - x86fp_kludge :: [Instr] -> [Instr] - x86fp_kludge = IF_ARCH_i386(i386_insert_ffrees,id) + where - regAlloc :: InstrBlock -> [Instr] - regAlloc = runRegAllocate allocatableRegs findReservedRegs -\end{code} + add_split (Cmm tops) + | opt_EnsureSplittableC = split_marker : tops + | otherwise = tops -Top level code generator for a chunk of stix code. For this part of -the computation, we switch from the UniqSM monad to the NatM monad. -The latter carries not only a Unique, but also an Int denoting the -current C stack pointer offset in the generated code; this is needed -for creating correct spill offsets on architectures which don't offer, -or for which it would be prohibitively expensive to employ, a frame -pointer register. Viz, x86. + split_marker = CmmProc [] mkSplitMarkerLabel [] [] -The offset is measured in bytes, and indicates the difference between -the current (simulated) C stack-ptr and the value it was at the -beginning of the block. For stacks which grow down, this value should -be either zero or negative. +#if darwin_TARGET_OS + -- Generate "symbol stubs" for all external symbols that might + -- come from a dynamic library. + dyld_stubs imps = Pretty.vcat $ map pprDyldSymbolStub $ + map head $ group $ sort imps +#else + dyld_stubs imps = Pretty.empty +#endif -Switching between the two monads whilst carrying along the same Unique -supply breaks abstraction. Is that bad? +#ifndef NCG_DEBUG + my_vcat sds = Pretty.vcat sds +#else + my_vcat sds = Pretty.vcat ( + intersperse ( + Pretty.char ' ' + Pretty.$$ Pretty.ptext SLIT("# ___ncg_debug_marker") + Pretty.$$ Pretty.char ' ' + ) + sds + ) +#endif -\begin{code} -genMachCode :: [StixStmt] -> UniqSM (InstrBlock, [FastString]) -genMachCode stmts initial_us +-- Complete native code generation phase for a single top-level chunk +-- of Cmm. + +cmmNativeGen :: DynFlags -> CmmTop -> UniqSM (CmmTop, Pretty.Doc, [(Bool,CLabel)]) +cmmNativeGen dflags cmm + = {-# SCC "fixAssigns" #-} + fixAssignsTop cmm `thenUs` \ fixed_cmm -> + {-# SCC "genericOpt" #-} + cmmToCmm fixed_cmm `bind` \ cmm -> + (if dopt Opt_D_dump_opt_cmm dflags -- space leak avoidance + then cmm + else CmmData Text []) `bind` \ ppr_cmm -> + {-# SCC "genMachCode" #-} + genMachCode cmm `thenUs` \ (pre_regalloc, imports) -> + {-# SCC "regAlloc" #-} + map regAlloc pre_regalloc `bind` \ with_regs -> + {-# SCC "sequenceBlocks" #-} + map sequenceTop with_regs `bind` \ sequenced -> + {-# SCC "x86fp_kludge" #-} + map x86fp_kludge sequenced `bind` \ final_mach_code -> + {-# SCC "vcat" #-} + Pretty.vcat (map pprNatCmmTop final_mach_code) `bind` \ final_sdoc -> + + returnUs (ppr_cmm, final_sdoc Pretty.$$ Pretty.text "", imports) + where + x86fp_kludge :: NatCmmTop -> NatCmmTop + x86fp_kludge top@(CmmData _ _) = top +#if i386_TARGET_ARCH + x86fp_kludge top@(CmmProc info lbl params code) = + CmmProc info lbl params (map bb_i386_insert_ffrees code) + where + bb_i386_insert_ffrees (BasicBlock id instrs) = + BasicBlock id (i386_insert_ffrees instrs) +#else + x86fp_kludge top = top +#endif + +-- ----------------------------------------------------------------------------- +-- Sequencing the basic blocks + +-- Cmm BasicBlocks are self-contained entities: they always end in a +-- jump, either non-local or to another basic block in the same proc. +-- In this phase, we attempt to place the basic blocks in a sequence +-- such that as many of the local jumps as possible turn into +-- fallthroughs. + +sequenceTop :: NatCmmTop -> NatCmmTop +sequenceTop top@(CmmData _ _) = top +sequenceTop (CmmProc info lbl params blocks) = + CmmProc info lbl params (sequenceBlocks blocks) + +-- The algorithm is very simple (and stupid): we make a graph out of +-- the blocks where there is an edge from one block to another iff the +-- first block ends by jumping to the second. Then we topologically +-- sort this graph. Then traverse the list: for each block, we first +-- output the block, then if it has an out edge, we move the +-- destination of the out edge to the front of the list, and continue. + +sequenceBlocks :: [NatBasicBlock] -> [NatBasicBlock] +sequenceBlocks [] = [] +sequenceBlocks (entry:blocks) = + seqBlocks (mkNode entry : reverse (flattenSCCs (sccBlocks blocks))) + -- the first block is the entry point ==> it must remain at the start. + +sccBlocks :: [NatBasicBlock] -> [SCC (NatBasicBlock,Unique,[Unique])] +sccBlocks blocks = stronglyConnCompR (map mkNode blocks) + +getOutEdges :: [Instr] -> [Unique] +getOutEdges instrs = case jumpDests (last instrs) [] of + [one] -> [getUnique one] + _many -> [] + -- we're only interested in the last instruction of + -- the block, and only if it has a single destination. + +mkNode block@(BasicBlock id instrs) = (block, getUnique id, getOutEdges instrs) + +seqBlocks [] = [] +seqBlocks ((block,_,[]) : rest) + = block : seqBlocks rest +seqBlocks ((block@(BasicBlock id instrs),_,[next]) : rest) + | can_fallthrough = BasicBlock id (init instrs) : seqBlocks rest' + | otherwise = block : seqBlocks rest' + where + (can_fallthrough, rest') = reorder next [] rest + -- TODO: we should do a better job for cycles; try to maximise the + -- fallthroughs within a loop. +seqBlocks _ = panic "AsmCodegen:seqBlocks" + +reorder id accum [] = (False, reverse accum) +reorder id accum (b@(block,id',out) : rest) + | id == id' = (True, (block,id,out) : reverse accum ++ rest) + | otherwise = reorder id (b:accum) rest + +-- ----------------------------------------------------------------------------- +-- Instruction selection + +-- Native code instruction selection for a chunk of stix code. For +-- this part of the computation, we switch from the UniqSM monad to +-- the NatM monad. The latter carries not only a Unique, but also an +-- Int denoting the current C stack pointer offset in the generated +-- code; this is needed for creating correct spill offsets on +-- architectures which don't offer, or for which it would be +-- prohibitively expensive to employ, a frame pointer register. Viz, +-- x86. + +-- The offset is measured in bytes, and indicates the difference +-- between the current (simulated) C stack-ptr and the value it was at +-- the beginning of the block. For stacks which grow down, this value +-- should be either zero or negative. + +-- Switching between the two monads whilst carrying along the same +-- Unique supply breaks abstraction. Is that bad? + +genMachCode :: CmmTop -> UniqSM ([NatCmmTop], [(Bool,CLabel)]) + +genMachCode cmm_top initial_us = let initial_st = mkNatM_State initial_us 0 - (instr_list, final_st) = initNat initial_st (stmtsToInstrs stmts) - final_us = uniqOfNatM_State final_st - final_delta = deltaOfNatM_State final_st - final_imports = importsOfNatM_State final_st + (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top) + final_us = natm_us final_st + final_delta = natm_delta final_st + final_imports = natm_imports final_st in if final_delta == 0 - then ((instr_list, final_imports), final_us) + then ((new_tops, final_imports), final_us) else pprPanic "genMachCode: nonzero final delta" (int final_delta) -\end{code} - -%************************************************************************ -%* * -\subsection[NCOpt]{The Generic Optimiser} -%* * -%************************************************************************ - -This is called between translating Abstract C to its Tree and actually -using the Native Code Generator to generate the annotations. It's a -chance to do some strength reductions. - -** Remember these all have to be machine independent *** - -Note that constant-folding should have already happened, but we might -have introduced some new opportunities for constant-folding wrt -address manipulations. - -\begin{code} -genericOpt :: [StixStmt] -> [StixStmt] -genericOpt = map stixStmt_ConFold . stixPeep - - - -stixPeep :: [StixStmt] -> [StixStmt] --- This transformation assumes that the temp assigned to in t1 --- is not assigned to in t2; for otherwise the target of the --- second assignment would be substituted for, giving nonsense --- code. As far as I can see, StixTemps are only ever assigned --- to once. It would be nice to be sure! - -stixPeep ( t1@(StAssignReg pka (StixTemp (StixVReg u pk)) rhs) - : t2 - : ts ) - | stixStmt_CountTempUses u t2 == 1 - && sum (map (stixStmt_CountTempUses u) ts) == 0 - = -# ifdef NCG_DEBUG - trace ("nativeGen: inlining " ++ showSDoc (pprStixExpr rhs)) -# endif - (stixPeep (stixStmt_Subst u rhs t2 : ts)) - -stixPeep (t1:t2:ts) = t1 : stixPeep (t2:ts) -stixPeep [t1] = [t1] -stixPeep [] = [] -\end{code} +-- ----------------------------------------------------------------------------- +-- Fixup assignments to global registers so that they assign to +-- locations within the RegTable, if appropriate. + +-- Note that we currently don't fixup reads here: they're done by +-- the generic optimiser below, to avoid having two separate passes +-- over the Cmm. + +fixAssignsTop :: CmmTop -> UniqSM CmmTop +fixAssignsTop top@(CmmData _ _) = returnUs top +fixAssignsTop (CmmProc info lbl params blocks) = + mapUs fixAssignsBlock blocks `thenUs` \ blocks' -> + returnUs (CmmProc info lbl params blocks') + +fixAssignsBlock :: CmmBasicBlock -> UniqSM CmmBasicBlock +fixAssignsBlock (BasicBlock id stmts) = + fixAssigns stmts `thenUs` \ stmts' -> + returnUs (BasicBlock id stmts') + +fixAssigns :: [CmmStmt] -> UniqSM [CmmStmt] +fixAssigns stmts = + mapUs fixAssign stmts `thenUs` \ stmtss -> + returnUs (concat stmtss) + +fixAssign :: CmmStmt -> UniqSM [CmmStmt] +fixAssign (CmmAssign (CmmGlobal BaseReg) src) + = panic "cmmStmtConFold: assignment to BaseReg"; + +fixAssign (CmmAssign (CmmGlobal reg) src) + | Left realreg <- reg_or_addr + = returnUs [CmmAssign (CmmGlobal reg) (cmmExprConFold src)] + | Right baseRegAddr <- reg_or_addr + = returnUs [CmmStore baseRegAddr src] + -- Replace register leaves with appropriate StixTrees for + -- the given target. GlobalRegs which map to a reg on this + -- arch are left unchanged. Assigning to BaseReg is always + -- illegal, so we check for that. + where + reg_or_addr = get_GlobalReg_reg_or_addr reg + +fixAssign (CmmCall target results args vols) + = mapAndUnzipUs fixResult results `thenUs` \ (results',stores) -> + returnUs (CmmCall target results' args vols : concat stores) + where + fixResult g@(CmmGlobal reg,hint) = + case get_GlobalReg_reg_or_addr reg of + Left realreg -> returnUs (g, []) + Right baseRegAddr -> + getUniqueUs `thenUs` \ uq -> + let local = CmmLocal (LocalReg uq (globalRegRep reg)) in + returnUs ((local,hint), + [CmmStore baseRegAddr (CmmReg local)]) + fixResult other = + returnUs (other,[]) + +fixAssign other_stmt = returnUs [other_stmt] + +-- ----------------------------------------------------------------------------- +-- Generic Cmm optimiser + +{- +Here we do: + + (a) Constant folding + (b) Simple inlining: a temporary which is assigned to and then + used, once, can be shorted. + (c) Replacement of references to GlobalRegs which do not have + machine registers by the appropriate memory load (eg. + Hp ==> *(BaseReg + 34) ). + +Ideas for other things we could do (ToDo): + + - shortcut jumps-to-jumps + - eliminate dead code blocks +-} + +cmmToCmm :: CmmTop -> CmmTop +cmmToCmm top@(CmmData _ _) = top +cmmToCmm (CmmProc info lbl params blocks) = + CmmProc info lbl params (map cmmBlockConFold (cmmPeep blocks)) + +cmmBlockConFold :: CmmBasicBlock -> CmmBasicBlock +cmmBlockConFold (BasicBlock id stmts) = BasicBlock id (map cmmStmtConFold stmts) + +cmmStmtConFold stmt + = case stmt of + CmmAssign reg src + -> case cmmExprConFold src of + CmmReg reg' | reg == reg' -> CmmNop + new_src -> CmmAssign reg new_src + + CmmStore addr src + -> CmmStore (cmmExprConFold addr) (cmmExprConFold src) + + CmmJump addr regs + -> CmmJump (cmmExprConFold addr) regs + + CmmCall target regs args vols + -> CmmCall (case target of + CmmForeignCall e conv -> + CmmForeignCall (cmmExprConFold e) conv + other -> other) + regs + [ (cmmExprConFold arg,hint) | (arg,hint) <- args ] + vols + + CmmCondBranch test dest + -> let test_opt = cmmExprConFold test + in + case test_opt of + CmmLit (CmmInt 0 _) -> + CmmComment (mkFastString ("deleted: " ++ + showSDoc (pprStmt stmt))) -For most nodes, just optimize the children. + CmmLit (CmmInt n _) -> CmmBranch dest + other -> CmmCondBranch (cmmExprConFold test) dest -\begin{code} -stixExpr_ConFold :: StixExpr -> StixExpr -stixStmt_ConFold :: StixStmt -> StixStmt + CmmSwitch expr ids + -> CmmSwitch (cmmExprConFold expr) ids -stixStmt_ConFold stmt - = case stmt of - StAssignReg pk reg@(StixTemp _) src - -> StAssignReg pk reg (stixExpr_ConFold src) - StAssignReg pk reg@(StixMagicId mid) src - -- Replace register leaves with appropriate StixTrees for - -- the given target. MagicIds which map to a reg on this arch are left unchanged. - -- Assigning to BaseReg is always illegal, so we check for that. - -> case mid of { - BaseReg -> panic "stixStmt_ConFold: assignment to BaseReg"; - other -> - case get_MagicId_reg_or_addr mid of - Left realreg - -> StAssignReg pk reg (stixExpr_ConFold src) - Right baseRegAddr - -> stixStmt_ConFold (StAssignMem pk baseRegAddr src) - } - StAssignMem pk addr src - -> StAssignMem pk (stixExpr_ConFold addr) (stixExpr_ConFold src) - StVoidable expr - -> StVoidable (stixExpr_ConFold expr) - StJump dsts addr - -> StJump dsts (stixExpr_ConFold addr) - StCondJump addr test - -> let test_opt = stixExpr_ConFold test - in - if manifestlyZero test_opt - then StComment (mkFastString ("deleted: " ++ showSDoc (pprStixStmt stmt))) - else StCondJump addr (stixExpr_ConFold test) - StData pk datas - -> StData pk (map stixExpr_ConFold datas) other -> other - where - manifestlyZero (StInt 0) = True - manifestlyZero other = False -stixExpr_ConFold expr + +cmmExprConFold expr = case expr of - StInd pk addr - -> StInd pk (stixExpr_ConFold addr) - StCall fn cconv pk args - -> StCall fn cconv pk (map stixExpr_ConFold args) - StIndex pk (StIndex pk' base off) off' - -- Fold indices together when the types match: - | pk == pk' - -> StIndex pk (stixExpr_ConFold base) - (stixExpr_ConFold (StMachOp MO_Nat_Add [off, off'])) - StIndex pk base off - -> StIndex pk (stixExpr_ConFold base) (stixExpr_ConFold off) - - StMachOp mop args - -- For PrimOps, we first optimize the children, and then we try + CmmLoad addr rep + -> CmmLoad (cmmExprConFold addr) rep + + CmmMachOp mop args + -- For MachOps, we first optimize the children, and then we try -- our hand at some constant-folding. - -> stixMachOpFold mop (map stixExpr_ConFold args) - StReg (StixMagicId mid) - -- Replace register leaves with appropriate StixTrees for - -- the given target. MagicIds which map to a reg on this arch are left unchanged. - -- For the rest, BaseReg is taken to mean the address of the reg table - -- in MainCapability, and for all others we generate an indirection to - -- its location in the register table. - -> case get_MagicId_reg_or_addr mid of + -> cmmMachOpFold mop (map cmmExprConFold args) + +#if powerpc_TARGET_ARCH + -- On powerpc, it's easier to jump directly to a label than + -- to use the register table, so we replace these registers + -- with the corresponding labels: + CmmReg (CmmGlobal GCEnter1) + -> CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "__stg_gc_enter_1"))) + CmmReg (CmmGlobal GCFun) + -> CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "__stg_gc_fun"))) +#endif + + CmmReg (CmmGlobal mid) + -- Replace register leaves with appropriate StixTrees for + -- the given target. MagicIds which map to a reg on this + -- arch are left unchanged. For the rest, BaseReg is taken + -- to mean the address of the reg table in MainCapability, + -- and for all others we generate an indirection to its + -- location in the register table. + -> case get_GlobalReg_reg_or_addr mid of Left realreg -> expr Right baseRegAddr -> case mid of - BaseReg -> stixExpr_ConFold baseRegAddr - other -> stixExpr_ConFold (StInd (magicIdPrimRep mid) baseRegAddr) + BaseReg -> cmmExprConFold baseRegAddr + other -> cmmExprConFold (CmmLoad baseRegAddr + (globalRegRep mid)) + -- eliminate zero offsets + CmmRegOff reg 0 + -> cmmExprConFold (CmmReg reg) + + CmmRegOff (CmmGlobal mid) offset + -- RegOf leaves are just a shorthand form. If the reg maps + -- to a real reg, we keep the shorthand, otherwise, we just + -- expand it and defer to the above code. + -> case get_GlobalReg_reg_or_addr mid of + Left realreg -> expr + Right baseRegAddr + -> cmmExprConFold (CmmMachOp (MO_Add wordRep) [ + CmmReg (CmmGlobal mid), + CmmLit (CmmInt (fromIntegral offset) + wordRep)]) other -> other -\end{code} -Now, try to constant-fold the PrimOps. The arguments have already -been optimized and folded. -\begin{code} -stixMachOpFold - :: MachOp -- The operation from an StMachOp - -> [StixExpr] -- The optimized arguments - -> StixExpr +-- ----------------------------------------------------------------------------- +-- MachOp constant folder -stixMachOpFold mop arg@[StInt x] - = case mop of - MO_NatS_Neg -> StInt (-x) - other -> StMachOp mop arg +-- Now, try to constant-fold the MachOps. The arguments have already +-- been optimized and folded. -stixMachOpFold mop args@[StInt x, StInt y] - = case mop of - MO_32U_Gt -> StInt (if x > y then 1 else 0) - MO_32U_Ge -> StInt (if x >= y then 1 else 0) - MO_32U_Eq -> StInt (if x == y then 1 else 0) - MO_32U_Ne -> StInt (if x /= y then 1 else 0) - MO_32U_Lt -> StInt (if x < y then 1 else 0) - MO_32U_Le -> StInt (if x <= y then 1 else 0) - MO_Nat_Add -> StInt (x + y) - MO_Nat_Sub -> StInt (x - y) - MO_NatS_Mul -> StInt (x * y) - MO_NatS_Quot | y /= 0 -> StInt (x `quot` y) - MO_NatS_Rem | y /= 0 -> StInt (x `rem` y) - MO_NatS_Gt -> StInt (if x > y then 1 else 0) - MO_NatS_Ge -> StInt (if x >= y then 1 else 0) - MO_Nat_Eq -> StInt (if x == y then 1 else 0) - MO_Nat_Ne -> StInt (if x /= y then 1 else 0) - MO_NatS_Lt -> StInt (if x < y then 1 else 0) - MO_NatS_Le -> StInt (if x <= y then 1 else 0) - MO_Nat_Shl | y >= 0 && y < 32 -> do_shl x y - other -> StMachOp mop args - where - do_shl :: Integer -> Integer -> StixExpr - do_shl v 0 = StInt v - do_shl v n | n > 0 = do_shl (v*2) (n-1) -\end{code} +cmmMachOpFold + :: MachOp -- The operation from an CmmMachOp + -> [CmmExpr] -- The optimized arguments + -> CmmExpr -When possible, shift the constants to the right-hand side, so that we -can match for strength reductions. Note that the code generator will -also assume that constants have been shifted to the right when -possible. +cmmMachOpFold op arg@[CmmLit (CmmInt x rep)] + = case op of + MO_S_Neg r -> CmmLit (CmmInt (-x) rep) + MO_Not r -> CmmLit (CmmInt (complement x) rep) -\begin{code} -stixMachOpFold op [x@(StInt _), y] | isCommutableMachOp op - = stixMachOpFold op [y, x] -\end{code} - -We can often do something with constants of 0 and 1 ... + -- these are interesting: we must first narrow to the + -- "from" type, in order to truncate to the correct size. + -- The final narrow/widen to the destination type + -- is implicit in the CmmLit. + MO_S_Conv from to -> CmmLit (CmmInt (narrowS from x) to) + MO_U_Conv from to -> CmmLit (CmmInt (narrowU from x) to) + _ -> panic "cmmMachOpFold: unknown unary op" -\begin{code} -stixMachOpFold mop args@[x, y@(StInt 0)] - = case mop of - MO_Nat_Add -> x - MO_Nat_Sub -> x - MO_NatS_Mul -> y - MO_NatU_Mul -> y - MO_Nat_And -> y - MO_Nat_Or -> x - MO_Nat_Xor -> x - MO_Nat_Shl -> x - MO_Nat_Shr -> x - MO_Nat_Sar -> x - MO_Nat_Ne | x_is_comparison -> x - other -> StMachOp mop args - where - x_is_comparison - = case x of - StMachOp mopp [_, _] -> isComparisonMachOp mopp - _ -> False +-- Eliminate conversion NOPs +cmmMachOpFold (MO_S_Conv rep1 rep2) [x] | rep1 == rep2 = x +cmmMachOpFold (MO_U_Conv rep1 rep2) [x] | rep1 == rep2 = x -stixMachOpFold mop args@[x, y@(StInt 1)] - = case mop of - MO_NatS_Mul -> x - MO_NatU_Mul -> x - MO_NatS_Quot -> x - MO_NatU_Quot -> x - MO_NatS_Rem -> StInt 0 - MO_NatU_Rem -> StInt 0 - other -> StMachOp mop args -\end{code} +-- ToDo: eliminate multiple conversions. Be careful though: can't remove +-- a narrowing, and can't remove conversions to/from floating point types. -Now look for multiplication/division by powers of 2 (integers). +-- ToDo: eliminate nested comparisons: +-- CmmMachOp MO_Lt [CmmMachOp MO_Eq [x,y], CmmLit (CmmInt 0 _)] +-- turns into a simple equality test. -\begin{code} -stixMachOpFold mop args@[x, y@(StInt n)] +cmmMachOpFold mop args@[CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)] = case mop of - MO_NatS_Mul + -- for comparisons: don't forget to narrow the arguments before + -- comparing, since they might be out of range. + MO_Eq r -> CmmLit (CmmInt (if x_u == y_u then 1 else 0) wordRep) + MO_Ne r -> CmmLit (CmmInt (if x_u /= y_u then 1 else 0) wordRep) + + MO_U_Gt r -> CmmLit (CmmInt (if x_u > y_u then 1 else 0) wordRep) + MO_U_Ge r -> CmmLit (CmmInt (if x_u >= y_u then 1 else 0) wordRep) + MO_U_Lt r -> CmmLit (CmmInt (if x_u < y_u then 1 else 0) wordRep) + MO_U_Le r -> CmmLit (CmmInt (if x_u <= y_u then 1 else 0) wordRep) + + MO_S_Gt r -> CmmLit (CmmInt (if x_s > y_s then 1 else 0) wordRep) + MO_S_Ge r -> CmmLit (CmmInt (if x_s >= y_s then 1 else 0) wordRep) + MO_S_Lt r -> CmmLit (CmmInt (if x_s < y_s then 1 else 0) wordRep) + MO_S_Le r -> CmmLit (CmmInt (if x_s <= y_s then 1 else 0) wordRep) + + MO_Add r -> CmmLit (CmmInt (x + y) r) + MO_Sub r -> CmmLit (CmmInt (x - y) r) + MO_Mul r -> CmmLit (CmmInt (x * y) r) + MO_S_Quot r | y /= 0 -> CmmLit (CmmInt (x `quot` y) r) + MO_S_Rem r | y /= 0 -> CmmLit (CmmInt (x `rem` y) r) + + MO_And r -> CmmLit (CmmInt (x .&. y) r) + MO_Or r -> CmmLit (CmmInt (x .|. y) r) + MO_Xor r -> CmmLit (CmmInt (x `xor` y) r) + + MO_Shl r -> CmmLit (CmmInt (x `shiftL` fromIntegral y) r) + MO_U_Shr r -> CmmLit (CmmInt (x_u `shiftR` fromIntegral y) r) + MO_S_Shr r -> CmmLit (CmmInt (x `shiftR` fromIntegral y) r) + + other -> CmmMachOp mop args + + where + x_u = narrowU xrep x + y_u = narrowU xrep y + x_s = narrowS xrep x + y_s = narrowS xrep y + + +-- When possible, shift the constants to the right-hand side, so that we +-- can match for strength reductions. Note that the code generator will +-- also assume that constants have been shifted to the right when +-- possible. + +cmmMachOpFold op [x@(CmmLit _), y] + | not (isLit y) && isCommutableMachOp op + = cmmMachOpFold op [y, x] + where + isLit (CmmLit _) = True + isLit _ = False + +-- Turn (a+b)+c into a+(b+c) where possible. Because literals are +-- moved to the right, it is more likely that we will find +-- opportunities for constant folding when the expression is +-- right-associated. +-- +-- ToDo: this appears to introduce a quadratic behaviour due to the +-- nested cmmMachOpFold. Can we fix this? +cmmMachOpFold mop1 [CmmMachOp mop2 [arg1,arg2], arg3] + | mop1 == mop2 && isAssociative mop1 + = cmmMachOpFold mop1 [arg1, cmmMachOpFold mop2 [arg2,arg3]] + where + isAssociative (MO_Add _) = True + isAssociative (MO_Mul _) = True + isAssociative (MO_And _) = True + isAssociative (MO_Or _) = True + isAssociative (MO_Xor _) = True + isAssociative _ = False + +-- Make a RegOff if we can +cmmMachOpFold (MO_Add _) [CmmReg reg, CmmLit (CmmInt n rep)] + = CmmRegOff reg (fromIntegral (narrowS rep n)) +cmmMachOpFold (MO_Add _) [CmmRegOff reg off, CmmLit (CmmInt n rep)] + = CmmRegOff reg (off + fromIntegral (narrowS rep n)) +cmmMachOpFold (MO_Sub _) [CmmReg reg, CmmLit (CmmInt n rep)] + = CmmRegOff reg (- fromIntegral (narrowS rep n)) +cmmMachOpFold (MO_Sub _) [CmmRegOff reg off, CmmLit (CmmInt n rep)] + = CmmRegOff reg (off - fromIntegral (narrowS rep n)) + +-- Fold label(+/-)offset into a CmmLit where possible + +cmmMachOpFold (MO_Add _) [CmmLit (CmmLabel lbl), CmmLit (CmmInt i rep)] + = CmmLit (CmmLabelOff lbl (fromIntegral (narrowU rep i))) +cmmMachOpFold (MO_Add _) [CmmLit (CmmInt i rep), CmmLit (CmmLabel lbl)] + = CmmLit (CmmLabelOff lbl (fromIntegral (narrowU rep i))) +cmmMachOpFold (MO_Sub _) [CmmLit (CmmLabel lbl), CmmLit (CmmInt i rep)] + = CmmLit (CmmLabelOff lbl (fromIntegral (negate (narrowU rep i)))) + +-- We can often do something with constants of 0 and 1 ... + +cmmMachOpFold mop args@[x, y@(CmmLit (CmmInt 0 _))] + = case mop of + MO_Add r -> x + MO_Sub r -> x + MO_Mul r -> y + MO_And r -> y + MO_Or r -> x + MO_Xor r -> x + MO_Shl r -> x + MO_S_Shr r -> x + MO_U_Shr r -> x + MO_Ne r | isComparisonExpr x -> x + MO_Eq r | Just x' <- maybeInvertConditionalExpr x -> x' + MO_U_Gt r | isComparisonExpr x -> x + MO_S_Gt r | isComparisonExpr x -> x + MO_U_Lt r | isComparisonExpr x -> CmmLit (CmmInt 0 wordRep) + MO_S_Lt r | isComparisonExpr x -> CmmLit (CmmInt 0 wordRep) + MO_U_Ge r | isComparisonExpr x -> CmmLit (CmmInt 1 wordRep) + MO_S_Ge r | isComparisonExpr x -> CmmLit (CmmInt 1 wordRep) + MO_U_Le r | Just x' <- maybeInvertConditionalExpr x -> x' + MO_S_Le r | Just x' <- maybeInvertConditionalExpr x -> x' + other -> CmmMachOp mop args + +cmmMachOpFold mop args@[x, y@(CmmLit (CmmInt 1 rep))] + = case mop of + MO_Mul r -> x + MO_S_Quot r -> x + MO_U_Quot r -> x + MO_S_Rem r -> CmmLit (CmmInt 0 rep) + MO_U_Rem r -> CmmLit (CmmInt 0 rep) + MO_Ne r | Just x' <- maybeInvertConditionalExpr x -> x' + MO_Eq r | isComparisonExpr x -> x + MO_U_Lt r | Just x' <- maybeInvertConditionalExpr x -> x' + MO_S_Lt r | Just x' <- maybeInvertConditionalExpr x -> x' + MO_U_Gt r | isComparisonExpr x -> CmmLit (CmmInt 0 wordRep) + MO_S_Gt r | isComparisonExpr x -> CmmLit (CmmInt 0 wordRep) + MO_U_Le r | isComparisonExpr x -> CmmLit (CmmInt 1 wordRep) + MO_S_Le r | isComparisonExpr x -> CmmLit (CmmInt 1 wordRep) + MO_U_Ge r | isComparisonExpr x -> x + MO_S_Ge r | isComparisonExpr x -> x + other -> CmmMachOp mop args + +-- Now look for multiplication/division by powers of 2 (integers). + +cmmMachOpFold mop args@[x, y@(CmmLit (CmmInt n _))] + = case mop of + MO_Mul rep -> case exactLog2 n of Nothing -> unchanged - Just p -> StMachOp MO_Nat_Shl [x, StInt p] - MO_NatS_Quot + Just p -> CmmMachOp (MO_Shl rep) [x, CmmLit (CmmInt p rep)] + MO_S_Quot rep -> case exactLog2 n of Nothing -> unchanged - Just p -> StMachOp MO_Nat_Shr [x, StInt p] + Just p -> CmmMachOp (MO_S_Shr rep) [x, CmmLit (CmmInt p rep)] other -> unchanged where - unchanged = StMachOp mop args + unchanged = CmmMachOp mop args + +-- Anything else is just too hard. + +cmmMachOpFold mop args = CmmMachOp mop args + + +-- ----------------------------------------------------------------------------- +-- exactLog2 + +-- This algorithm for determining the $\log_2$ of exact powers of 2 comes +-- from GCC. It requires bit manipulation primitives, and we use GHC +-- extensions. Tough. +-- +-- Used to be in MachInstrs --SDM. +-- ToDo: remove use of unboxery --SDM. + +w2i x = word2Int# x +i2w x = int2Word# x + +exactLog2 :: Integer -> Maybe Integer +exactLog2 x + = if (x <= 0 || x >= 2147483648) then + Nothing + else + case iUnbox (fromInteger x) of { x# -> + if (w2i ((i2w x#) `and#` (i2w (0# -# x#))) /=# x#) then + Nothing + else + Just (toInteger (iBox (pow2 x#))) + } + where + pow2 x# | x# ==# 1# = 0# + | otherwise = 1# +# pow2 (w2i (i2w x# `shiftRL#` 1#)) + + +-- ----------------------------------------------------------------------------- +-- widening / narrowing + +narrowU :: MachRep -> Integer -> Integer +narrowU I8 x = fromIntegral (fromIntegral x :: Word8) +narrowU I16 x = fromIntegral (fromIntegral x :: Word16) +narrowU I32 x = fromIntegral (fromIntegral x :: Word32) +narrowU I64 x = fromIntegral (fromIntegral x :: Word64) +narrowU _ _ = panic "narrowTo" + +narrowS :: MachRep -> Integer -> Integer +narrowS I8 x = fromIntegral (fromIntegral x :: Int8) +narrowS I16 x = fromIntegral (fromIntegral x :: Int16) +narrowS I32 x = fromIntegral (fromIntegral x :: Int32) +narrowS I64 x = fromIntegral (fromIntegral x :: Int64) +narrowS _ _ = panic "narrowTo" + +-- ----------------------------------------------------------------------------- +-- The mini-inliner + +-- This pass inlines assignments to temporaries that are used just +-- once in the very next statement only. Generalising this would be +-- quite difficult (have to take into account aliasing of memory +-- writes, and so on), but at the moment it catches a number of useful +-- cases and lets the code generator generate much better code. + +-- NB. This assumes that temporaries are single-assignment. + +cmmPeep :: [CmmBasicBlock] -> [CmmBasicBlock] +cmmPeep blocks = map do_inline blocks + where + blockUses (BasicBlock _ stmts) + = foldr (plusUFM_C (+)) emptyUFM (map getStmtUses stmts) + + uses = foldr (plusUFM_C (+)) emptyUFM (map blockUses blocks) + + do_inline (BasicBlock id stmts) + = BasicBlock id (cmmMiniInline uses stmts) + + +cmmMiniInline :: UniqFM Int -> [CmmStmt] -> [CmmStmt] +cmmMiniInline uses [] = [] +cmmMiniInline uses (stmt@(CmmAssign (CmmLocal (LocalReg u _)) expr) : stmts) + | Just 1 <- lookupUFM uses u, + Just stmts' <- lookForInline u expr stmts + = +#ifdef NCG_DEBUG + trace ("nativeGen: inlining " ++ showSDoc (pprStmt stmt)) $ +#endif + cmmMiniInline uses stmts' + +cmmMiniInline uses (stmt:stmts) + = stmt : cmmMiniInline uses stmts + + +-- Try to inline a temporary assignment. We can skip over assignments to +-- other tempoararies, because we know that expressions aren't side-effecting +-- and temporaries are single-assignment. +lookForInline u expr (stmt@(CmmAssign (CmmLocal (LocalReg u' _)) rhs) : rest) + | u /= u' + = case lookupUFM (getExprUses rhs) u of + Just 1 -> Just (inlineStmt u expr stmt : rest) + _other -> case lookForInline u expr rest of + Nothing -> Nothing + Just stmts -> Just (stmt:stmts) + +lookForInline u expr (stmt:stmts) + = case lookupUFM (getStmtUses stmt) u of + Just 1 -> Just (inlineStmt u expr stmt : stmts) + _other -> Nothing + +-- ----------------------------------------------------------------------------- +-- Boring Cmm traversals for collecting usage info and substitutions. + +getStmtUses :: CmmStmt -> UniqFM Int +getStmtUses (CmmAssign _ e) = getExprUses e +getStmtUses (CmmStore e1 e2) = plusUFM_C (+) (getExprUses e1) (getExprUses e2) +getStmtUses (CmmCall target _ es _) + = plusUFM_C (+) (uses target) (getExprsUses (map fst es)) + where uses (CmmForeignCall e _) = getExprUses e + uses _ = emptyUFM +getStmtUses (CmmCondBranch e _) = getExprUses e +getStmtUses (CmmSwitch e _) = getExprUses e +getStmtUses (CmmJump e _) = getExprUses e +getStmtUses _ = emptyUFM + +getExprUses :: CmmExpr -> UniqFM Int +getExprUses (CmmReg (CmmLocal (LocalReg u _))) = unitUFM u 1 +getExprUses (CmmRegOff (CmmLocal (LocalReg u _)) _) = unitUFM u 1 +getExprUses (CmmLoad e _) = getExprUses e +getExprUses (CmmMachOp _ es) = getExprsUses es +getExprUses _other = emptyUFM + +getExprsUses es = foldr (plusUFM_C (+)) emptyUFM (map getExprUses es) + +inlineStmt :: Unique -> CmmExpr -> CmmStmt -> CmmStmt +inlineStmt u a (CmmAssign r e) = CmmAssign r (inlineExpr u a e) +inlineStmt u a (CmmStore e1 e2) = CmmStore (inlineExpr u a e1) (inlineExpr u a e2) +inlineStmt u a (CmmCall target regs es vols) + = CmmCall (infn target) regs es' vols + where infn (CmmForeignCall fn cconv) = CmmForeignCall fn cconv + infn (CmmPrim p) = CmmPrim p + es' = [ (inlineExpr u a e, hint) | (e,hint) <- es ] +inlineStmt u a (CmmCondBranch e d) = CmmCondBranch (inlineExpr u a e) d +inlineStmt u a (CmmSwitch e d) = CmmSwitch (inlineExpr u a e) d +inlineStmt u a (CmmJump e d) = CmmJump (inlineExpr u a e) d +inlineStmt u a other_stmt = other_stmt + +inlineExpr :: Unique -> CmmExpr -> CmmExpr -> CmmExpr +inlineExpr u a e@(CmmReg (CmmLocal (LocalReg u' _))) + | u == u' = a + | otherwise = e +inlineExpr u a e@(CmmRegOff (CmmLocal (LocalReg u' rep)) off) + | u == u' = CmmMachOp (MO_Add rep) [a, CmmLit (CmmInt (fromIntegral off) rep)] + | otherwise = e +inlineExpr u a (CmmLoad e rep) = CmmLoad (inlineExpr u a e) rep +inlineExpr u a (CmmMachOp op es) = CmmMachOp op (map (inlineExpr u a) es) +inlineExpr u a other_expr = other_expr + +-- ----------------------------------------------------------------------------- +-- Utils + +bind f x = x $! f + +isComparisonExpr :: CmmExpr -> Bool +isComparisonExpr (CmmMachOp op _) = isComparisonMachOp op +isComparisonExpr _other = False + +maybeInvertConditionalExpr :: CmmExpr -> Maybe CmmExpr +maybeInvertConditionalExpr (CmmMachOp op args) + | Just op' <- maybeInvertComparison op = Just (CmmMachOp op' args) +maybeInvertConditionalExpr _ = Nothing \end{code} -Anything else is just too hard. - -\begin{code} -stixMachOpFold mop args = StMachOp mop args -\end{code} diff --git a/ghc/compiler/nativeGen/AsmRegAlloc.lhs b/ghc/compiler/nativeGen/AsmRegAlloc.lhs deleted file mode 100644 index 90b379a8b8..0000000000 --- a/ghc/compiler/nativeGen/AsmRegAlloc.lhs +++ /dev/null @@ -1,941 +0,0 @@ -% -% (c) The AQUA Project, Glasgow University, 1993-2000 -% -\section[AsmRegAlloc]{Register allocator} - -\begin{code} -module AsmRegAlloc ( runRegAllocate ) where - -#include "HsVersions.h" - -import MachCode ( InstrBlock ) -import MachMisc ( Instr(..) ) -import PprMach ( pprInstr ) -- Just for debugging -import MachRegs -import RegAllocInfo - -import FiniteMap ( FiniteMap, emptyFM, - lookupFM, eltsFM, addToFM_C, addToFM, - listToFM, fmToList ) -import OrdList ( fromOL ) -import Outputable -import Unique ( mkPseudoUnique3 ) -import CLabel ( CLabel, pprCLabel ) -import FastTypes - -import List ( mapAccumL, nub, sort ) -import Array ( Array, array, (!), bounds ) -\end{code} - -This is the generic register allocator. It does allocation for all -architectures. Details for specific architectures are given in -RegAllocInfo.lhs. In practice the allocator needs to know next to -nothing about an architecture to do its job: - -* It needs to be given a list of the registers it can allocate to. - -* It needs to be able to find out which registers each insn reads and - writes. - -* It needs be able to change registers in instructions into other - registers. - -* It needs to be able to find out where execution could go after an - in instruction. - -* It needs to be able to discover sets of registers which can be - used to attempt spilling. - -First we try something extremely simple. If that fails, we have to do -things the hard way. - -\begin{code} -runRegAllocate - :: [Reg] - -> ([Instr] -> [[Reg]]) - -> InstrBlock - -> [Instr] - -runRegAllocate regs find_reserve_regs instrs - = --trace ("runRegAllocate: " ++ show regs) ( - case simpleAlloc of - Just simple -> --trace "SIMPLE" - simple - Nothing -> --trace "GENERAL" - (tryGeneral reserves) - --) - where - tryGeneral [] - = pprPanic "nativeGen: spilling failed. Workaround: compile with -fvia-C.\n" - ( (text "reserves = " <> ppr reserves) - $$ - (text "code = ") - $$ - (vcat (map (docToSDoc.pprInstr) flatInstrs)) - ) - tryGeneral (resv:resvs) - = case generalAlloc resv of - Just success -> success - Nothing -> tryGeneral resvs - - reserves = find_reserve_regs flatInstrs - flatInstrs = fromOL instrs - simpleAlloc = doSimpleAlloc regs flatInstrs - generalAlloc resvd = doGeneralAlloc regs resvd flatInstrs -\end{code} - -Rather than invoke the heavyweight machinery in @doGeneralAlloc@ for -each and every code block, we first try using this simple, fast and -utterly braindead allocator. In practice it handles about 60\% of the -code blocks really fast, even with only 3 integer registers available. -Since we can always give up and fall back to @doGeneralAlloc@, -@doSimpleAlloc@ is geared to handling the common case as fast as -possible. It will succeed only if: - -* The code mentions registers only of integer class, not floating - class. - -* The code doesn't mention any real registers, so we don't have to - think about dodging and weaving to work around fixed register uses. - -* The code mentions at most N virtual registers, where N is the number - of real registers for allocation. - -If those conditions are satisfied, we simply trundle along the code, -doling out a real register every time we see mention of a new virtual -register. We either succeed at this, or give up when one of the above -three conditions is no longer satisfied. - -\begin{code} -doSimpleAlloc :: [Reg] -> [Instr] -> Maybe [Instr] -doSimpleAlloc available_real_regs instrs - = let available_iregs - = filter ((== RcInteger).regClass) available_real_regs - - trundle :: [( {-Virtual-}Reg, {-Real-}Reg )] - -> [ {-Real-}Reg ] - -> [Instr] - -> [Instr] - -> Maybe [Instr] - trundle vreg_map uncommitted_rregs ris_done [] - = Just (reverse ris_done) - trundle vreg_map uncommitted_rregs ris_done (i:is) - = case regUsage i of - RU rds wrs - - -- Mentions no regs? Move on quickly - | null rds_l && null wrs_l - -> trundle vreg_map uncommitted_rregs (i:ris_done) is - - -- A case we can't be bothered to handle? - | any isFloatingOrReal rds_l || any isFloatingOrReal wrs_l - -> Nothing - - -- Update the rreg commitments, and map the insn - | otherwise - -> case upd_commitment (wrs_l++rds_l) - vreg_map uncommitted_rregs of - Nothing -- out of rregs; give up - -> Nothing - Just (vreg_map2, uncommitted_rregs2) - -> let i2 = patchRegs i (subst_reg vreg_map2) - in trundle vreg_map2 uncommitted_rregs2 - (i2:ris_done) is - where - isFloatingOrReal reg - = isRealReg reg || regClass reg == RcFloat - || regClass reg == RcDouble - - rds_l = regSetToList rds - wrs_l = regSetToList wrs - - upd_commitment [] vr_map uncomm - = Just (vr_map, uncomm) - upd_commitment (reg:regs) vr_map uncomm - | isRealReg reg - = upd_commitment regs vr_map uncomm - | reg `elem` (map fst vr_map) - = upd_commitment regs vr_map uncomm - | null uncomm - = Nothing - | otherwise - = upd_commitment regs ((reg, head uncomm):vr_map) - (tail uncomm) - - subst_reg vreg_map r - -- If it's a RealReg, it must be STG-specific one - -- (Hp,Sp,BaseReg,etc), since regUsage filters them out, - -- so isFloatingOrReal would not have objected to it. - | isRealReg r - = r - | otherwise - = case [rr | (vr,rr) <- vreg_map, vr == r] of - [rr2] -> rr2 - other -> pprPanic - "doSimpleAlloc: unmapped VirtualReg" - (ppr r) - in - trundle [] available_iregs [] instrs -\end{code} - -From here onwards is the general register allocator and spiller. For -each flow edge (possible transition between instructions), we compute -which virtual and real registers are live on that edge. Then the -mapping is inverted, to give a mapping from register (virtual+real) to -sets of flow edges on which the register is live. Finally, we can use -those sets to decide whether a virtual reg v can be assigned to a real -reg r, by checking that v's live-edge-set does not intersect with r's -current live-edge-set. Having made that assignment, we then augment -r's current live-edge-set (its current commitment, you could say) with -v's live-edge-set. - -doGeneralAlloc takes reserve_regs as the regs to use as spill -temporaries. First it tries to allocate using all regs except -reserve_regs. If that fails, it inserts spill code and tries again to -allocate regs, but this time with the spill temporaries available. -Even this might not work if there are insufficient spill temporaries: -in the worst case on x86, we'd need 3 of them, for insns like addl -(%reg1,%reg2,4) %reg3, since this insn uses all 3 regs as input. - -\begin{code} -doGeneralAlloc - :: [Reg] -- all allocatable regs - -> [Reg] -- the reserve regs - -> [Instr] -- instrs in - -> Maybe [Instr] -- instrs out - -doGeneralAlloc all_regs reserve_regs instrs - -- succeeded without spilling - | prespill_ok - = Just prespill_insns - - -- failed, and no spill regs avail, so pointless to attempt spilling - | null reserve_regs = Nothing - -- success after spilling - | postspill_ok = maybetrace (spillMsg True) (Just postspill_insns) - -- still not enough reserves after spilling; we have to give up - | otherwise = maybetrace (spillMsg False) Nothing - where - prespill_regs - = filter (`notElem` reserve_regs) all_regs - (prespill_ok, prespill_insns) - = allocUsingTheseRegs instrs prespill_regs - instrs_with_spill_code - = insertSpillCode prespill_insns - (postspill_ok, postspill_insns) - = allocUsingTheseRegs instrs_with_spill_code all_regs - - spillMsg success - = "nativeGen: spilling " - ++ (if success then "succeeded" else "failed ") - ++ " using " - ++ showSDoc (hsep (map ppr reserve_regs)) - -# ifdef NCG_DEBUG - maybetrace msg x = trace msg x -# else - maybetrace msg x = x -# endif -\end{code} - -Here we patch instructions that reference ``registers'' which are -really in memory somewhere (the mapping is under the control of the -machine-specific code generator). We place the appropriate load -sequences before any instructions that use memory registers as -sources, and we place the appropriate spill sequences after any -instructions that use memory registers as destinations. The offending -instructions are rewritten with new dynamic registers, so generalAlloc -has to run register allocation again after all of this is said and -done. - -On some architectures (x86, currently), we do without a frame-pointer, -and instead spill relative to the stack pointer (%esp on x86). -Because the stack pointer may move, the patcher needs to keep track of -the current stack pointer "delta". That's easy, because all it needs -to do is spot the DELTA bogus-insns which will have been inserted by -the relevant insn selector precisely so as to notify the spiller of -stack-pointer movement. The delta is passed to loadReg and spillReg, -since they generate the actual spill code. We expect the final delta -to be the same as the starting one (zero), reflecting the fact that -changes to the stack pointer should not extend beyond a basic block. - -Finally, there is the issue of mapping an arbitrary set of unallocated -VirtualRegs into a contiguous sequence of spill slots. The failed -allocation will have left the code peppered with references to -VirtualRegs, each of which contains a unique. So we make an env which -maps these VirtualRegs to integers, starting from zero, and pass that -env through to loadReg and spillReg. There, they are used to look up -spill slot numbers for the uniques. - -\begin{code} -insertSpillCode :: [Instr] -> [Instr] -insertSpillCode insns - = let uniques_in_insns - = map getVRegUnique - (regSetToList - (foldl unionRegSets emptyRegSet - (map vregs_in_insn insns))) - vregs_in_insn i - = case regUsage i of - RU rds wrs -> filterRegSet isVirtualReg - (rds `unionRegSets` wrs) - vreg_to_slot_map :: FiniteMap VRegUnique Int - vreg_to_slot_map - = listToFM (zip uniques_in_insns [0..]) - - ((final_stack_delta, final_ctr), insnss) - = mapAccumL (patchInstr vreg_to_slot_map) (0,0) insns - in - if final_stack_delta == 0 - then concat insnss - else pprPanic "patchMem: non-zero final delta" - (int final_stack_delta) - - --- patchInstr has as a running state two Ints, one the current stack delta, --- needed to figure out offsets to stack slots on archs where we spill relative --- to the stack pointer, as opposed to the frame pointer. The other is a --- counter, used to manufacture new temporary register names. - -patchInstr :: FiniteMap VRegUnique Int -> (Int,Int) -> Instr -> ((Int,Int), [Instr]) -patchInstr vreg_to_slot_map (delta,ctr) instr - - | null memSrcs && null memDsts - = ((delta',ctr), [instr]) - - | otherwise - = ((delta',ctr'), loadSrcs ++ [instr'] ++ spillDsts) - where - delta' = case instr of DELTA d -> d ; _ -> delta - - (RU srcs dsts) = regUsage instr - - -- The instr being patched may mention several vregs -- those which - -- could not be assigned real registers. For each such vreg, we - -- invent a new vreg, used only around this instruction and nowhere - -- else. These new vregs replace the unallocatable vregs; they are - -- loaded from the spill area, the instruction is done with them, - -- and results if any are then written back to the spill area. - vregs_in_instr - = nub (filter isVirtualReg - (regSetToList srcs ++ regSetToList dsts)) - n_vregs_in_instr - = length vregs_in_instr - ctr' - = ctr + n_vregs_in_instr - vreg_env - = zip vregs_in_instr [ctr, ctr+1 ..] - - mkTmpReg vreg - | isVirtualReg vreg - = case [vi | (vreg', vi) <- vreg_env, vreg' == vreg] of - [i] -> case regClass vreg of - RcInteger -> VirtualRegI (pseudoVReg i) - RcFloat -> VirtualRegF (pseudoVReg i) - RcDouble -> VirtualRegD (pseudoVReg i) - _ -> pprPanic "patchInstr: unmapped VReg" (ppr vreg) - | otherwise - = vreg - - pseudoVReg i = VRegUniqueLo (mkPseudoUnique3 i) - - memSrcs = filter isVirtualReg (regSetToList srcs) - memDsts = filter isVirtualReg (regSetToList dsts) - - loadSrcs = map load memSrcs - spillDsts = map spill memDsts - - load mem = loadReg vreg_to_slot_map delta mem (mkTmpReg mem) - spill mem = spillReg vreg_to_slot_map delta' (mkTmpReg mem) mem - - instr' = patchRegs instr mkTmpReg -\end{code} - -allocUsingTheseRegs is the register allocator proper. It attempts -to allocate dynamic regs to real regs, given a list of real regs -which it may use. If it fails due to lack of real regs, the returned -instructions use what real regs there are, but will retain uses of -dynamic regs for which a real reg could not be found. It is these -leftover dynamic reg references which insertSpillCode will later -assign to spill slots. - -Some implementation notes. -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Instructions are numbered sequentially, starting at zero. - -A flow edge (FE) is a pair of insn numbers (MkFE Int Int) denoting -a possible flow of control from the first insn to the second. - -The input to the register allocator is a list of instructions, which -mention Regs. A Reg can be a RealReg -- a real machine reg -- or a -VirtualReg, which carries a unique. After allocation, all the -VirtualReg references will have been converted into RealRegs, and -possible some spill code will have been inserted. - -The heart of the register allocator works in four phases. - -1. (find_flow_edges) Calculate all the FEs for the code list. - Return them not as a [FE], but implicitly, as a pair of - Array Int [Int], being the successor and predecessor maps - for instructions. - -2. (calc_liveness) Returns a FiniteMap FE RegSet. For each - FE, indicates the set of registers live on that FE. Note - that the set includes both RealRegs and VirtualRegs. The - former appear because the code could mention fixed register - usages, and we need to take them into account from the start. - -3. (calc_live_range_sets) Invert the above mapping, giving a - FiniteMap Reg FeSet, indicating, for each virtual and real - reg mentioned in the code, which FEs it is live on. - -4. (calc_vreg_to_rreg_mapping) For virtual reg, try and find - an allocatable real register for it. Each real register has - a "current commitment", indicating the set of FEs it is - currently live on. A virtual reg v can be assigned to - real reg r iff v's live-fe-set does not intersect with r's - current commitment fe-set. If the assignment is made, - v's live-fe-set is union'd into r's current commitment fe-set. - There is also the minor restriction that v and r must be of - the same register class (integer or floating). - - Once this mapping is established, we simply apply it to the - input insns, and that's it. - - If no suitable real register can be found, the vreg is mapped - to itself, and we deem allocation to have failed. The partially - allocated code is returned. The higher echelons of the allocator - (doGeneralAlloc and runRegAlloc) then cooperate to insert spill - code and re-run allocation, until a successful allocation is found. -\begin{code} - -allocUsingTheseRegs :: [Instr] -> [Reg] -> (Bool, [Instr]) -allocUsingTheseRegs instrs available_real_regs - = let (all_vregs_mapped, v_to_r_mapping) - = calc_vreg_to_rreg_mapping instrs available_real_regs - new_insns - = map (flip patchRegs sr) instrs - sr reg - | isRealReg reg - = reg - | otherwise - = case lookupFM v_to_r_mapping reg of - Just r -> r - Nothing -> pprPanic "allocateUsingTheseRegs: unmapped vreg: " - (ppr reg) - in - --trace ("allocUsingTheseRegs: " ++ show available_real_regs) ( - (all_vregs_mapped, new_insns) - --) - - --- the heart of the matter. -calc_vreg_to_rreg_mapping :: [Instr] -> [Reg] -> (Bool, FiniteMap Reg Reg) -calc_vreg_to_rreg_mapping insns available_real_regs - = let - lr_sets :: FiniteMap Reg FeSet - lr_sets = calc_live_range_sets insns - - -- lr_sets maps: vregs mentioned in insns to sets of live FEs - -- and also: rregs mentioned in insns to sets of live FEs - -- We need to extract the rreg mapping, and use it as the - -- initial real-register-commitment. Also, add to the initial - -- commitment, empty commitments for any real regs not - -- mentioned in it. - - -- which real regs do we want to keep track of in the running - -- commitment mapping? Precisely the available_real_regs. - -- We don't care about real regs mentioned by insns which are - -- not in this list, since we're not allocating to them. - initial_rr_commitment :: FiniteMap Reg FeSet - initial_rr_commitment - = listToFM [(rreg, - case lookupFM lr_sets rreg of - Nothing -> emptyFeSet - Just fixed_use_fes -> fixed_use_fes - ) - | rreg <- available_real_regs] - - -- These are the vregs for which we actually have to (try to) - -- assign a real register. (ie, the whole reason we're here at all :) - vreg_liveness_list :: [(Reg, FeSet)] - vreg_liveness_list = filter (not.isRealReg.fst) - (fmToList lr_sets) - - -- A loop, which attempts to assign each vreg to a rreg. - loop rr_commitment v_to_r_map [] - = v_to_r_map - loop rr_commitment v_to_r_map ((vreg,vreg_live_fes):not_yet_done) - = let - -- find a real reg which is not live for any of vreg_live_fes - cand_reals - = [rreg - | (rreg,rreg_live_FEs) <- fmToList rr_commitment, - regClass vreg == regClass rreg, - isEmptyFeSet (intersectionFeSets rreg_live_FEs - vreg_live_fes) - ] - in - case cand_reals of - [] -> -- bummer. No register is available. Just go on to - -- the next vreg, mapping the vreg to itself. - loop rr_commitment (addToFM v_to_r_map vreg vreg) - not_yet_done - (r:_) - -> -- Hurrah! Found a free reg of the right class. - -- Now we need to update the RR commitment. - loop rr_commitment2 (addToFM v_to_r_map vreg r) - not_yet_done - where - rr_commitment2 - = addToFM_C unionFeSets rr_commitment r - vreg_live_fes - - -- the final vreg to rreg mapping - vreg_assignment - = loop initial_rr_commitment emptyFM vreg_liveness_list - -- did we succeed in mapping everyone to a real reg? - allocation_succeeded - = all isRealReg (eltsFM vreg_assignment) - in - (allocation_succeeded, vreg_assignment) - - - --- calculate liveness, then produce the live range info --- as a mapping of VRegs to the set of FEs on which they are live. --- The difficult part is inverting the mapping of Reg -> FeSet --- to produce a mapping FE -> RegSet. - -calc_live_range_sets :: [Instr] -> FiniteMap Reg FeSet -calc_live_range_sets insns - = let - -- this is the "original" (old) mapping - lis :: FiniteMap FE RegSet - lis = calc_liveness insns - - -- establish the totality of reg names mentioned by the - -- insns, by scanning over the insns. - all_mentioned_regs :: RegSet - all_mentioned_regs - = foldl unionRegSets emptyRegSet - (map (\i -> case regUsage i of - RU rds wrs -> unionRegSets rds wrs) - insns) - - -- Initial inverted mapping, from Reg to sets of FEs - initial_imap :: FiniteMap Reg FeSet - initial_imap - = listToFM [(reg, emptyFeSet) - | reg <- regSetToList all_mentioned_regs] - - -- Update the new map with one element of the old map - upd_imap :: FiniteMap Reg FeSet -> (FE, RegSet) - -> FiniteMap Reg FeSet - upd_imap imap (fe, regset) - = foldl upd_1_imap imap (regSetToList regset) - where - upd_1_imap curr reg - = addToFM_C unionFeSets curr reg (unitFeSet fe) - - -- the complete inverse mapping - final_imap :: FiniteMap Reg FeSet - final_imap - = foldl upd_imap initial_imap (fmToList lis) - in - final_imap - - - --- Given the insns, calculate the FEs, and then doing fixpointing to --- figure out the set of live regs (virtual regs AND real regs) live --- on each FE. - -calc_liveness :: [Instr] -> FiniteMap FE RegSet -calc_liveness insns - = let (pred_map, succ_map) - = find_flow_edges insns - - -- We use the convention that if the current approximation - -- doesn't give a mapping for some FE, that FE maps to the - -- empty set. - initial_approx, fixpoint :: FiniteMap FE RegSet - initial_approx - = mk_initial_approx 0 insns succ_map emptyFM - fixpoint - = fix_set initial_approx 1 - -- If you want to live dangerously, and promise that the code - -- doesn't contain any loops (ie, there are no back edges in - -- the flow graph), you should be able to get away with this: - -- = upd_liveness_info pred_map succ_map insn_array initial_approx - -- But since I'm paranoid, and since it hardly makes any difference - -- to the compiler run-time (about 0.1%), I prefer to do the - -- the full fixpointing game. - - insn_array - = let n = length insns - in array (0, n-1) (zip [0..] insns) - - sameSets [] [] = True - sameSets (c:cs) (n:ns) = eqRegSets c n && sameSets cs ns - sameSets _ _ = False - - fix_set curr_approx iter_number - = let next_approx - = upd_liveness_info pred_map succ_map insn_array curr_approx - curr_sets - = eltsFM curr_approx - next_sets - = eltsFM next_approx - same - = sameSets curr_sets next_sets - final_approx - = if same then curr_approx - else fix_set next_approx (iter_number+1) - in - --trace (let qqq (fe, regset) - -- = show fe ++ " " ++ show (regSetToList regset) - -- in - -- "\n::iteration " ++ show iter_number ++ "\n" - -- ++ (unlines . map qqq . fmToList) - -- next_approx ++"\n" - -- ) - final_approx - in - fixpoint - - --- Create a correct initial approximation. For each instruction that --- writes a register, we deem that the register is live on the --- flow edges leaving the instruction. Subsequent iterations of --- the liveness AbI augment this based purely on reads of regs, not --- writes. We need to start off with at least this minimal write- --- based information in order that writes to vregs which are never --- used have non-empty live ranges. If we don't do that, we eventually --- wind up assigning such vregs to any old real reg, since they don't --- apparently conflict -- you can't conflict with an empty live range. --- This kludge is unfortunate, but we need to do it to cover not only --- writes to vregs which are never used, but also to deal correctly --- with the fact that calls to C will trash the callee saves registers. - -mk_initial_approx :: Int -> [Instr] -> Array Int [Int] - -> FiniteMap FE RegSet - -> FiniteMap FE RegSet -mk_initial_approx ino [] succ_map ia_so_far - = ia_so_far -mk_initial_approx ino (i:is) succ_map ia_so_far - = let wrs - = case regUsage i of RU rrr www -> www - new_fes - = [case iUnbox ino of { inoh -> - case iUnbox ino_succ of { ino_succh -> - MkFE inoh ino_succh - }} - | ino_succ <- succ_map ! ino] - - loop [] ia = ia - loop (fe:fes) ia - = loop fes (addToFM_C unionRegSets ia fe wrs) - - next_ia - = loop new_fes ia_so_far - in - mk_initial_approx (ino+1) is succ_map next_ia - - --- Do one step in the liveness info calculation (AbI :). Given the --- prior approximation (which tells you a subset of live VRegs+RRegs --- for each flow edge), calculate new information for all FEs. --- Rather than do this by iterating over FEs, it's easier to iterate --- over insns, and update their incoming FEs. - -upd_liveness_info :: Array Int [Int] -- instruction pred map - -> Array Int [Int] -- instruction succ map - -> Array Int Instr -- array of instructions - -> FiniteMap FE RegSet -- previous approx - -> FiniteMap FE RegSet -- improved approx - -upd_liveness_info pred_map succ_map insn_array prev_approx - = do_insns hi prev_approx - where - (lo, hi) = bounds insn_array - - enquireMapFE :: FiniteMap FE RegSet -> FE - -> RegSet - enquireMapFE fm fe - = case lookupFM fm fe of - Just set -> set - Nothing -> emptyRegSet - - -- Work backwards, from the highest numbered insn to the lowest. - -- This is a heuristic which causes faster convergence to the - -- fixed point. In particular, for straight-line code with no - -- branches at all, arrives at the fixpoint in one iteration. - do_insns ino approx - | ino < lo - = approx - | otherwise - = let fes_to_futures - = [case iUnbox ino of { inoh -> - case iUnbox future_ino of { future_inoh -> - MkFE inoh future_inoh - }} - | future_ino <- succ_map ! ino] - future_lives - = map (enquireMapFE approx) fes_to_futures - future_live - = foldr unionRegSets emptyRegSet future_lives - - fes_from_histories - = [case iUnbox history_ino of { history_inoh -> - case iUnbox ino of { inoh -> - MkFE history_inoh inoh - }} - | history_ino <- pred_map ! ino] - new_approx - = foldl update_one_history approx fes_from_histories - - insn - = insn_array ! ino - history_independent_component - = case regUsage insn of - RU rds wrs - -> unionRegSets rds - (minusRegSets future_live wrs) - - update_one_history :: FiniteMap FE RegSet - -> FE - -> FiniteMap FE RegSet - update_one_history approx0 fe - = addToFM_C unionRegSets approx0 fe - history_independent_component - - rest_done - = do_insns (ino-1) new_approx - in - rest_done - - - --- Extract the flow edges from a list of insns. Express the information --- as two mappings, from insn number to insn numbers of predecessors, --- and from insn number to insn numbers of successors. (Since that's --- what we need to know when computing live ranges later). Instructions --- are numbered starting at zero. This function is long and complex --- in order to be efficient; it could equally well be shorter and slower. - -find_flow_edges :: [Instr] -> (Array Int [Int], - Array Int [Int]) -find_flow_edges insns - = let - -- First phase: make a temp env which maps labels - -- to insn numbers, so the second pass can know the insn - -- numbers for jump targets. - - label_env :: FiniteMap CLabel Int - - mk_label_env n env [] = env - mk_label_env n env ((LABEL clbl):is) - = mk_label_env (n+1) (addToFM env clbl n) is - mk_label_env n env (i:is) - = mk_label_env (n+1) env is - - label_env = mk_label_env 0 emptyFM insns - - find_label :: CLabel -> Int - find_label jmptarget - = case lookupFM label_env jmptarget of - Just ino -> ino - Nothing -> pprPanic "find_flow_edges: unmapped label" - (pprCLabel jmptarget) - - -- Second phase: traverse the insns, and make up the successor map. - - least_ino, greatest_ino :: Int - least_ino = 0 - greatest_ino = length insns - 1 - - mk_succ_map :: Int -> [(Int, [Int])] -> [Instr] -> [(Int, [Int])] - - mk_succ_map i_num rsucc_map [] - = reverse rsucc_map - - mk_succ_map i_num rsucc_map (i:is) - = let i_num_1 = i_num + 1 - in - case insnFuture i of - - NoFuture - -> -- A non-local jump. We can regard this insn as a terminal - -- insn in the graph, so we don't add any edges. - mk_succ_map i_num_1 ((i_num,[]):rsucc_map) is - - Next - | null is -- this is the last insn, and it doesn't go anywhere - -- (a meaningless scenario); handle it anyway - -> mk_succ_map i_num_1 ((i_num,[]):rsucc_map) is - - | otherwise -- flows to next insn; add fe i_num -> i_num+1 - -> mk_succ_map i_num_1 ((i_num, [i_num_1]): rsucc_map) - is - - Branch lab -- jmps to lab; add fe i_num -> i_target - -> let i_target = find_label lab - in - mk_succ_map i_num_1 ((i_num, [i_target]): rsucc_map) is - - NextOrBranch lab - | null is -- jmps to label, or falls through, and this is - -- the last insn (a meaningless scenario); - -- flag an error - -> error "find_flow_edges: NextOrBranch is last" - - | otherwise -- add fes i_num -> i_num+1 - -- and i_num -> i_target - -> let i_target = find_label lab - in - mk_succ_map i_num_1 ((i_num, [i_num_1, i_target]):rsucc_map) - is - MultiFuture labels - -> -- A jump, whose targets are listed explicitly. - -- (Generated from table-based switch translations). - -- Add fes i_num -> x for each x in labels - let is_target = nub (map find_label labels) - in - mk_succ_map i_num_1 ((i_num, is_target):rsucc_map) is - - -- Third phase: invert the successor map to get the predecessor - -- map, using an algorithm which is quadratic in the worst case, - -- but runs in almost-linear time, because of the nature of our - -- inputs: most insns have a single successor, the next insn. - - invert :: [(Int, [Int])] -> [(Int, [Int])] - invert fmap - = let inverted_pairs - = concatMap ( \ (a, bs) -> [(b,a) | b <- bs] ) fmap - sorted_inverted_pairs - = isort inverted_pairs - - grp :: Int -> [Int] -> [(Int,Int)] -> [(Int,[Int])] - grp k vs [] = [(k, vs)] - grp k vs ((kk,vv):rest) - | k == kk = grp k (vv:vs) rest - | otherwise = (k,vs) : grp kk [vv] rest - - grp_start [] = [] - grp_start ((kk,vv):rest) = grp kk [vv] rest - - grouped - = grp_start sorted_inverted_pairs - - -- make sure that the reverse mapping maps all inos - add_empties ino [] - | ino > greatest_ino = [] - | otherwise = (ino,[]): add_empties (ino+1) [] - add_empties ino ((k,vs):rest) - | ino < k = (ino,[]): add_empties (ino+1) ((k,vs):rest) - | ino == k = (k,vs) : add_empties (ino+1) rest - - -- This is nearly linear provided that the fsts of the - -- list are nearly in order -- a critical assumption - -- for efficiency. - isort :: [(Int,Int)] -> [(Int,Int)] - isort [] = [] - isort (x:xs) = insert x (isort xs) - - insert :: (Int,Int) -> [(Int,Int)] -> [(Int,Int)] - insert y [] = [y] - insert y (z:zs) - -- specifically, this first test should almost always - -- be True in order for the near-linearity to happen - | fst y <= fst z = y:z:zs - | otherwise = z: insert y zs - in - add_empties least_ino grouped - - -- Finally ... - - succ_list - = mk_succ_map 0 [] insns - succ_map - = array (least_ino, greatest_ino) succ_list - pred_list - = invert succ_list - pred_map - = array (least_ino, greatest_ino) pred_list - in - (pred_map, succ_map) - - --- That's all, folks! From here on is just some dull supporting stuff. - --- A data type for flow edges -data FE - = MkFE FastInt FastInt deriving (Eq, Ord) - --- deriving Show on types with unboxed fields doesn't work -instance Show FE where - showsPrec _ (MkFE s d) - = showString "MkFE" . shows (iBox s) . shows ' ' . shows (iBox d) - --- Blargh. Use ghc stuff soon! Or: perhaps that's not such a good --- idea. Most of these sets are either empty or very small, and it --- might be that the overheads of the FiniteMap based set implementation --- is a net loss. The same might be true of RegSets. - -newtype FeSet = MkFeSet [FE] - -feSetFromList xs - = MkFeSet (nukeDups (sort xs)) - where nukeDups :: [FE] -> [FE] - nukeDups [] = [] - nukeDups [x] = [x] - nukeDups (x:y:xys) - = if x == y then nukeDups (y:xys) - else x : nukeDups (y:xys) - -feSetToList (MkFeSet xs) = xs -isEmptyFeSet (MkFeSet xs) = null xs -emptyFeSet = MkFeSet [] -eqFeSet (MkFeSet xs1) (MkFeSet xs2) = xs1 == xs2 -unitFeSet x = MkFeSet [x] - -elemFeSet x (MkFeSet xs) - = f xs - where - f [] = False - f (y:ys) | x == y = True - | x < y = False - | otherwise = f ys - -unionFeSets (MkFeSet xs1) (MkFeSet xs2) - = MkFeSet (f xs1 xs2) - where - f [] bs = bs - f as [] = as - f (a:as) (b:bs) - | a < b = a : f as (b:bs) - | a > b = b : f (a:as) bs - | otherwise = a : f as bs - -minusFeSets (MkFeSet xs1) (MkFeSet xs2) - = MkFeSet (f xs1 xs2) - where - f [] bs = [] - f as [] = as - f (a:as) (b:bs) - | a < b = a : f as (b:bs) - | a > b = f (a:as) bs - | otherwise = f as bs - -intersectionFeSets (MkFeSet xs1) (MkFeSet xs2) - = MkFeSet (f xs1 xs2) - where - f [] bs = [] - f as [] = [] - f (a:as) (b:bs) - | a < b = f as (b:bs) - | a > b = f (a:as) bs - | otherwise = a : f as bs - -\end{code} diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs deleted file mode 100644 index 2876efd361..0000000000 --- a/ghc/compiler/nativeGen/MachCode.lhs +++ /dev/null @@ -1,4628 +0,0 @@ -% -% (c) The AQUA Project, Glasgow University, 1996-1998 -% -\section[MachCode]{Generating machine code} - -This is a big module, but, if you pay attention to -(a) the sectioning, (b) the type signatures, and -(c) the \tr{#if blah_TARGET_ARCH} things, the -structure should not be too overwhelming. - -\begin{code} -module MachCode ( stmtsToInstrs, InstrBlock ) where - -#include "HsVersions.h" -#include "nativeGen/NCG.h" - -import MachMisc -- may differ per-platform -import MachRegs -import OrdList ( OrdList, nilOL, isNilOL, unitOL, appOL, toOL, - snocOL, consOL, concatOL ) -import MachOp ( MachOp(..), pprMachOp ) -import AbsCUtils ( magicIdPrimRep ) -import PprAbsC ( pprMagicId ) -import ForeignCall ( CCallConv(..) ) -import CLabel ( CLabel, labelDynamic ) -#if sparc_TARGET_ARCH || alpha_TARGET_ARCH -import CLabel ( isAsmTemp ) -#endif -import Maybes ( maybeToBool ) -import PrimRep ( isFloatingRep, is64BitRep, PrimRep(..), -#if powerpc_TARGET_ARCH - getPrimRepSize, -#endif - getPrimRepSizeInBytes ) -import Stix ( getNatLabelNCG, StixStmt(..), StixExpr(..), - StixReg(..), pprStixReg, StixVReg(..), CodeSegment(..), - DestInfo, hasDestInfo, - pprStixExpr, repOfStixExpr, - NatM, thenNat, returnNat, mapNat, - mapAndUnzipNat, mapAccumLNat, - getDeltaNat, setDeltaNat, - IF_ARCH_powerpc(addImportNat COMMA,) - ncgPrimopMoan, - ncg_target_is_32bit - ) -import Pretty -import Outputable ( panic, pprPanic, showSDoc ) -import qualified Outputable -import CmdLineOpts ( opt_Static ) -import Stix ( pprStixStmt ) - -import Maybe ( fromMaybe ) - --- DEBUGGING ONLY -import Outputable ( assertPanic ) -import FastString -import TRACE ( trace ) - -infixr 3 `bind` -\end{code} - -@InstrBlock@s are the insn sequences generated by the insn selectors. -They are really trees of insns to facilitate fast appending, where a -left-to-right traversal (pre-order?) yields the insns in the correct -order. - -\begin{code} -type InstrBlock = OrdList Instr - -x `bind` f = f x - -isLeft (Left _) = True -isLeft (Right _) = False - -unLeft (Left x) = x -\end{code} - -Code extractor for an entire stix tree---stix statement level. - -\begin{code} -stmtsToInstrs :: [StixStmt] -> NatM InstrBlock -stmtsToInstrs stmts - = mapNat stmtToInstrs stmts `thenNat` \ instrss -> - returnNat (concatOL instrss) - - -stmtToInstrs :: StixStmt -> NatM InstrBlock -stmtToInstrs stmt = case stmt of - StComment s -> returnNat (unitOL (COMMENT s)) - StSegment seg -> returnNat (unitOL (SEGMENT seg)) - - StFunBegin lab -> returnNat (unitOL (IF_ARCH_alpha(FUNBEGIN lab, - LABEL lab))) - StFunEnd lab -> IF_ARCH_alpha(returnNat (unitOL (FUNEND lab)), - returnNat nilOL) - - StLabel lab -> returnNat (unitOL (LABEL lab)) - - StJump dsts arg -> genJump dsts (derefDLL arg) - StCondJump lab arg -> genCondJump lab (derefDLL arg) - - -- A call returning void, ie one done for its side-effects. Note - -- that this is the only StVoidable we handle. - StVoidable (StCall fn cconv VoidRep args) - -> genCCall fn cconv VoidRep (map derefDLL args) - - StAssignMem pk addr src - | isFloatingRep pk -> assignMem_FltCode pk (derefDLL addr) (derefDLL src) - | ncg_target_is_32bit - && is64BitRep pk -> assignMem_I64Code (derefDLL addr) (derefDLL src) - | otherwise -> assignMem_IntCode pk (derefDLL addr) (derefDLL src) - StAssignReg pk reg src - | isFloatingRep pk -> assignReg_FltCode pk reg (derefDLL src) - | ncg_target_is_32bit - && is64BitRep pk -> assignReg_I64Code reg (derefDLL src) - | otherwise -> assignReg_IntCode pk reg (derefDLL src) - - StFallThrough lbl - -- When falling through on the Alpha, we still have to load pv - -- with the address of the next routine, so that it can load gp. - -> IF_ARCH_alpha(returnInstr (LDA pv (AddrImm (ImmCLbl lbl))) - ,returnNat nilOL) - - StData kind args - -> mapAndUnzipNat getData args `thenNat` \ (codes, imms) -> - returnNat (DATA (primRepToSize kind) imms - `consOL` concatOL codes) - where - getData :: StixExpr -> NatM (InstrBlock, Imm) - getData (StInt i) = returnNat (nilOL, ImmInteger i) - getData (StDouble d) = returnNat (nilOL, ImmDouble d) - getData (StFloat d) = returnNat (nilOL, ImmFloat d) - getData (StCLbl l) = returnNat (nilOL, ImmCLbl l) - getData (StString s) = panic "MachCode.stmtToInstrs: unlifted StString" - -- the linker can handle simple arithmetic... - getData (StIndex rep (StCLbl lbl) (StInt off)) = - returnNat (nilOL, - ImmIndex lbl (fromInteger off * getPrimRepSizeInBytes rep)) - - -- Top-level lifted-out string. The segment will already have been set - -- (see Stix.liftStrings). - StDataString str - -> returnNat (unitOL (ASCII True (unpackFS str))) - -#ifdef DEBUG - other -> pprPanic "stmtToInstrs" (pprStixStmt other) -#endif - --- Walk a Stix tree, and insert dereferences to CLabels which are marked --- as labelDynamic. stmt2Instrs calls derefDLL selectively, because --- not all such CLabel occurrences need this dereferencing -- SRTs don't --- for one. -derefDLL :: StixExpr -> StixExpr -derefDLL tree - | opt_Static -- short out the entire deal if not doing DLLs - = tree - | otherwise - = qq tree - where - qq t - = case t of - StCLbl lbl -> if labelDynamic lbl - then StInd PtrRep (StCLbl lbl) - else t - -- all the rest are boring - StIndex pk base offset -> StIndex pk (qq base) (qq offset) - StMachOp mop args -> StMachOp mop (map qq args) - StInd pk addr -> StInd pk (qq addr) - StCall (Left nm) cc pk args -> StCall (Left nm) cc pk (map qq args) - StCall (Right f) cc pk args -> StCall (Right (qq f)) cc pk (map qq args) - StInt _ -> t - StFloat _ -> t - StDouble _ -> t - StString _ -> t - StReg _ -> t - _ -> pprPanic "derefDLL: unhandled case" - (pprStixExpr t) -\end{code} - -%************************************************************************ -%* * -\subsection{General things for putting together code sequences} -%* * -%************************************************************************ - -\begin{code} -mangleIndexTree :: StixExpr -> StixExpr - -mangleIndexTree (StIndex pk base (StInt i)) - = StMachOp MO_Nat_Add [base, off] - where - off = StInt (i * toInteger (getPrimRepSizeInBytes pk)) - -mangleIndexTree (StIndex pk base off) - = StMachOp MO_Nat_Add [ - base, - let s = shift pk - in if s == 0 then off - else StMachOp MO_Nat_Shl [off, StInt (toInteger s)] - ] - where - shift :: PrimRep -> Int - shift rep = case getPrimRepSizeInBytes rep of - 1 -> 0 - 2 -> 1 - 4 -> 2 - 8 -> 3 - other -> pprPanic "MachCode.mangleIndexTree.shift: unhandled rep size" - (Outputable.int other) -\end{code} - -\begin{code} -maybeImm :: StixExpr -> Maybe Imm - -maybeImm (StCLbl l) - = Just (ImmCLbl l) -maybeImm (StIndex rep (StCLbl l) (StInt off)) - = Just (ImmIndex l (fromInteger off * getPrimRepSizeInBytes rep)) -maybeImm (StInt i) - | i >= toInteger (minBound::Int) && i <= toInteger (maxBound::Int) - = Just (ImmInt (fromInteger i)) - | otherwise - = Just (ImmInteger i) - -maybeImm _ = Nothing -\end{code} - -%************************************************************************ -%* * -\subsection{The @Register64@ type} -%* * -%************************************************************************ - -Simple support for generating 64-bit code (ie, 64 bit values and 64 -bit assignments) on 32-bit platforms. Unlike the main code generator -we merely shoot for generating working code as simply as possible, and -pay little attention to code quality. Specifically, there is no -attempt to deal cleverly with the fixed-vs-floating register -distinction; all values are generated into (pairs of) floating -registers, even if this would mean some redundant reg-reg moves as a -result. Only one of the VRegUniques is returned, since it will be -of the VRegUniqueLo form, and the upper-half VReg can be determined -by applying getHiVRegFromLo to it. - -\begin{code} - -data ChildCode64 -- a.k.a "Register64" - = ChildCode64 - InstrBlock -- code - VRegUnique -- unique for the lower 32-bit temporary - -- which contains the result; use getHiVRegFromLo to find - -- the other VRegUnique. - -- Rules of this simplified insn selection game are - -- therefore that the returned VRegUnique may be modified - -assignMem_I64Code :: StixExpr -> StixExpr -> NatM InstrBlock -assignReg_I64Code :: StixReg -> StixExpr -> NatM InstrBlock -iselExpr64 :: StixExpr -> NatM ChildCode64 - --- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#if i386_TARGET_ARCH - -assignMem_I64Code addrTree valueTree - = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vrlo) -> - getRegister addrTree `thenNat` \ register_addr -> - getNewRegNCG IntRep `thenNat` \ t_addr -> - let rlo = VirtualRegI vrlo - rhi = getHiVRegFromLo rlo - code_addr = registerCode register_addr t_addr - reg_addr = registerName register_addr t_addr - -- Little-endian store - mov_lo = MOV L (OpReg rlo) - (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 0))) - mov_hi = MOV L (OpReg rhi) - (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 4))) - in - returnNat (vcode `appOL` code_addr `snocOL` mov_lo `snocOL` mov_hi) - -assignReg_I64Code (StixTemp (StixVReg u_dst pk)) valueTree - = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vr_src_lo) -> - let - r_dst_lo = mkVReg u_dst IntRep - r_src_lo = VirtualRegI vr_src_lo - r_dst_hi = getHiVRegFromLo r_dst_lo - r_src_hi = getHiVRegFromLo r_src_lo - mov_lo = MOV L (OpReg r_src_lo) (OpReg r_dst_lo) - mov_hi = MOV L (OpReg r_src_hi) (OpReg r_dst_hi) - in - returnNat ( - vcode `snocOL` mov_lo `snocOL` mov_hi - ) - -assignReg_I64Code lvalue valueTree - = pprPanic "assignReg_I64Code(i386): invalid lvalue" - (pprStixReg lvalue) - - - -iselExpr64 (StInd pk addrTree) - | is64BitRep pk - = getRegister addrTree `thenNat` \ register_addr -> - getNewRegNCG IntRep `thenNat` \ t_addr -> - getNewRegNCG IntRep `thenNat` \ rlo -> - let rhi = getHiVRegFromLo rlo - code_addr = registerCode register_addr t_addr - reg_addr = registerName register_addr t_addr - mov_lo = MOV L (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 0))) - (OpReg rlo) - mov_hi = MOV L (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 4))) - (OpReg rhi) - in - returnNat ( - ChildCode64 (code_addr `snocOL` mov_lo `snocOL` mov_hi) - (getVRegUnique rlo) - ) - -iselExpr64 (StReg (StixTemp (StixVReg vu pk))) - | is64BitRep pk - = getNewRegNCG IntRep `thenNat` \ r_dst_lo -> - let r_dst_hi = getHiVRegFromLo r_dst_lo - r_src_lo = mkVReg vu IntRep - r_src_hi = getHiVRegFromLo r_src_lo - mov_lo = MOV L (OpReg r_src_lo) (OpReg r_dst_lo) - mov_hi = MOV L (OpReg r_src_hi) (OpReg r_dst_hi) - in - returnNat ( - ChildCode64 (toOL [mov_lo, mov_hi]) (getVRegUnique r_dst_lo) - ) - -iselExpr64 (StCall fn cconv kind args) - | is64BitRep kind - = genCCall fn cconv kind args `thenNat` \ call -> - getNewRegNCG IntRep `thenNat` \ r_dst_lo -> - let r_dst_hi = getHiVRegFromLo r_dst_lo - mov_lo = MOV L (OpReg eax) (OpReg r_dst_lo) - mov_hi = MOV L (OpReg edx) (OpReg r_dst_hi) - in - returnNat ( - ChildCode64 (call `snocOL` mov_lo `snocOL` mov_hi) - (getVRegUnique r_dst_lo) - ) - -iselExpr64 expr - = pprPanic "iselExpr64(i386)" (pprStixExpr expr) - -#endif /* i386_TARGET_ARCH */ - --- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#if sparc_TARGET_ARCH - -assignMem_I64Code addrTree valueTree - = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vrlo) -> - getRegister addrTree `thenNat` \ register_addr -> - getNewRegNCG IntRep `thenNat` \ t_addr -> - let rlo = VirtualRegI vrlo - rhi = getHiVRegFromLo rlo - code_addr = registerCode register_addr t_addr - reg_addr = registerName register_addr t_addr - -- Big-endian store - mov_hi = ST W rhi (AddrRegImm reg_addr (ImmInt 0)) - mov_lo = ST W rlo (AddrRegImm reg_addr (ImmInt 4)) - in - returnNat (vcode `appOL` code_addr `snocOL` mov_hi `snocOL` mov_lo) - - -assignReg_I64Code (StixTemp (StixVReg u_dst pk)) valueTree - = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vr_src_lo) -> - let - r_dst_lo = mkVReg u_dst IntRep - r_src_lo = VirtualRegI vr_src_lo - r_dst_hi = getHiVRegFromLo r_dst_lo - r_src_hi = getHiVRegFromLo r_src_lo - mov_lo = mkMOV r_src_lo r_dst_lo - mov_hi = mkMOV r_src_hi r_dst_hi - mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg - in - returnNat ( - vcode `snocOL` mov_hi `snocOL` mov_lo - ) -assignReg_I64Code lvalue valueTree - = pprPanic "assignReg_I64Code(sparc): invalid lvalue" - (pprStixReg lvalue) - - --- Don't delete this -- it's very handy for debugging. ---iselExpr64 expr --- | trace ("iselExpr64: " ++ showSDoc (pprStixExpr expr)) False --- = panic "iselExpr64(???)" - -iselExpr64 (StInd pk addrTree) - | is64BitRep pk - = getRegister addrTree `thenNat` \ register_addr -> - getNewRegNCG IntRep `thenNat` \ t_addr -> - getNewRegNCG IntRep `thenNat` \ rlo -> - let rhi = getHiVRegFromLo rlo - code_addr = registerCode register_addr t_addr - reg_addr = registerName register_addr t_addr - mov_hi = LD W (AddrRegImm reg_addr (ImmInt 0)) rhi - mov_lo = LD W (AddrRegImm reg_addr (ImmInt 4)) rlo - in - returnNat ( - ChildCode64 (code_addr `snocOL` mov_hi `snocOL` mov_lo) - (getVRegUnique rlo) - ) - -iselExpr64 (StReg (StixTemp (StixVReg vu pk))) - | is64BitRep pk - = getNewRegNCG IntRep `thenNat` \ r_dst_lo -> - let r_dst_hi = getHiVRegFromLo r_dst_lo - r_src_lo = mkVReg vu IntRep - r_src_hi = getHiVRegFromLo r_src_lo - mov_lo = mkMOV r_src_lo r_dst_lo - mov_hi = mkMOV r_src_hi r_dst_hi - mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg - in - returnNat ( - ChildCode64 (toOL [mov_hi, mov_lo]) (getVRegUnique r_dst_lo) - ) - -iselExpr64 (StCall fn cconv kind args) - | is64BitRep kind - = genCCall fn cconv kind args `thenNat` \ call -> - getNewRegNCG IntRep `thenNat` \ r_dst_lo -> - let r_dst_hi = getHiVRegFromLo r_dst_lo - mov_lo = mkMOV o0 r_dst_lo - mov_hi = mkMOV o1 r_dst_hi - mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg - in - returnNat ( - ChildCode64 (call `snocOL` mov_hi `snocOL` mov_lo) - (getVRegUnique r_dst_lo) - ) - -iselExpr64 expr - = pprPanic "iselExpr64(sparc)" (pprStixExpr expr) - -#endif /* sparc_TARGET_ARCH */ --- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#if powerpc_TARGET_ARCH - -assignMem_I64Code addrTree valueTree - = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vrlo) -> - getRegister addrTree `thenNat` \ register_addr -> - getNewRegNCG IntRep `thenNat` \ t_addr -> - let rlo = VirtualRegI vrlo - rhi = getHiVRegFromLo rlo - code_addr = registerCode register_addr t_addr - reg_addr = registerName register_addr t_addr - -- Big-endian store - mov_hi = ST W rhi (AddrRegImm reg_addr (ImmInt 0)) - mov_lo = ST W rlo (AddrRegImm reg_addr (ImmInt 4)) - in - returnNat (vcode `appOL` code_addr `snocOL` mov_hi `snocOL` mov_lo) - - -assignReg_I64Code (StixTemp (StixVReg u_dst pk)) valueTree - = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vr_src_lo) -> - let - r_dst_lo = mkVReg u_dst IntRep - r_src_lo = VirtualRegI vr_src_lo - r_dst_hi = getHiVRegFromLo r_dst_lo - r_src_hi = getHiVRegFromLo r_src_lo - mov_lo = MR r_dst_lo r_src_lo - mov_hi = MR r_dst_hi r_src_hi - in - returnNat ( - vcode `snocOL` mov_hi `snocOL` mov_lo - ) -assignReg_I64Code lvalue valueTree - = pprPanic "assignReg_I64Code(powerpc): invalid lvalue" - (pprStixReg lvalue) - - --- Don't delete this -- it's very handy for debugging. ---iselExpr64 expr --- | trace ("iselExpr64: " ++ showSDoc (pprStixExpr expr)) False --- = panic "iselExpr64(???)" - -iselExpr64 (StInd pk addrTree) - | is64BitRep pk - = getRegister addrTree `thenNat` \ register_addr -> - getNewRegNCG IntRep `thenNat` \ t_addr -> - getNewRegNCG IntRep `thenNat` \ rlo -> - let rhi = getHiVRegFromLo rlo - code_addr = registerCode register_addr t_addr - reg_addr = registerName register_addr t_addr - mov_hi = LD W rhi (AddrRegImm reg_addr (ImmInt 0)) - mov_lo = LD W rlo (AddrRegImm reg_addr (ImmInt 4)) - in - returnNat ( - ChildCode64 (code_addr `snocOL` mov_hi `snocOL` mov_lo) - (getVRegUnique rlo) - ) - -iselExpr64 (StReg (StixTemp (StixVReg vu pk))) - | is64BitRep pk - = getNewRegNCG IntRep `thenNat` \ r_dst_lo -> - let r_dst_hi = getHiVRegFromLo r_dst_lo - r_src_lo = mkVReg vu IntRep - r_src_hi = getHiVRegFromLo r_src_lo - mov_lo = MR r_dst_lo r_src_lo - mov_hi = MR r_dst_hi r_src_hi - in - returnNat ( - ChildCode64 (toOL [mov_hi, mov_lo]) (getVRegUnique r_dst_lo) - ) - -iselExpr64 (StCall fn cconv kind args) - | is64BitRep kind - = genCCall fn cconv kind args `thenNat` \ call -> - getNewRegNCG IntRep `thenNat` \ r_dst_lo -> - let r_dst_hi = getHiVRegFromLo r_dst_lo - mov_lo = MR r_dst_lo r4 - mov_hi = MR r_dst_hi r3 - in - returnNat ( - ChildCode64 (call `snocOL` mov_hi `snocOL` mov_lo) - (getVRegUnique r_dst_lo) - ) - -iselExpr64 expr - = pprPanic "iselExpr64(powerpc)" (pprStixExpr expr) - -#endif /* powerpc_TARGET_ARCH */ - --- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -\end{code} - -%************************************************************************ -%* * -\subsection{The @Register@ type} -%* * -%************************************************************************ - -@Register@s passed up the tree. If the stix code forces the register -to live in a pre-decided machine register, it comes out as @Fixed@; -otherwise, it comes out as @Any@, and the parent can decide which -register to put it in. - -\begin{code} -data Register - = Fixed PrimRep Reg InstrBlock - | Any PrimRep (Reg -> InstrBlock) - -registerCode :: Register -> Reg -> InstrBlock -registerCode (Fixed _ _ code) reg = code -registerCode (Any _ code) reg = code reg - -registerCodeF (Fixed _ _ code) = code -registerCodeF (Any _ _) = panic "registerCodeF" - -registerCodeA (Any _ code) = code -registerCodeA (Fixed _ _ _) = panic "registerCodeA" - -registerName :: Register -> Reg -> Reg -registerName (Fixed _ reg _) _ = reg -registerName (Any _ _) reg = reg - -registerNameF (Fixed _ reg _) = reg -registerNameF (Any _ _) = panic "registerNameF" - -registerRep :: Register -> PrimRep -registerRep (Fixed pk _ _) = pk -registerRep (Any pk _) = pk - -swizzleRegisterRep :: Register -> PrimRep -> Register -swizzleRegisterRep (Fixed _ reg code) rep = Fixed rep reg code -swizzleRegisterRep (Any _ codefn) rep = Any rep codefn - -{-# INLINE registerCode #-} -{-# INLINE registerCodeF #-} -{-# INLINE registerName #-} -{-# INLINE registerNameF #-} -{-# INLINE registerRep #-} -{-# INLINE isFixed #-} -{-# INLINE isAny #-} - -isFixed, isAny :: Register -> Bool -isFixed (Fixed _ _ _) = True -isFixed (Any _ _) = False - -isAny = not . isFixed -\end{code} - -Generate code to get a subtree into a @Register@: -\begin{code} - -getRegisterReg :: StixReg -> NatM Register -getRegister :: StixExpr -> NatM Register - - -getRegisterReg (StixMagicId mid) - = case get_MagicId_reg_or_addr mid of - Left (RealReg rrno) - -> let pk = magicIdPrimRep mid - in returnNat (Fixed pk (RealReg rrno) nilOL) - Right baseRegAddr - -- By this stage, the only MagicIds remaining should be the - -- ones which map to a real machine register on this platform. Hence ... - -> pprPanic "getRegisterReg-memory" (pprMagicId mid) - -getRegisterReg (StixTemp (StixVReg u pk)) - = returnNat (Fixed pk (mkVReg u pk) nilOL) - -------------- - --- Don't delete this -- it's very handy for debugging. ---getRegister expr --- | trace ("getRegiste: " ++ showSDoc (pprStixExpr expr)) False --- = panic "getRegister(???)" - -getRegister (StReg reg) - = getRegisterReg reg - -getRegister tree@(StIndex _ _ _) - = getRegister (mangleIndexTree tree) - -getRegister (StCall fn cconv kind args) - | not (ncg_target_is_32bit && is64BitRep kind) - = genCCall fn cconv kind args `thenNat` \ call -> - returnNat (Fixed kind reg call) - where - reg = if isFloatingRep kind - then IF_ARCH_alpha( f0, IF_ARCH_i386( fake0, IF_ARCH_sparc( f0, IF_ARCH_powerpc( f1,)))) - else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0, IF_ARCH_powerpc( r3,)))) - -getRegister (StString s) - = getNatLabelNCG `thenNat` \ lbl -> - let - imm_lbl = ImmCLbl lbl - - code dst = toOL [ - SEGMENT RoDataSegment, - LABEL lbl, - ASCII True (unpackFS s), - SEGMENT TextSegment, -#if alpha_TARGET_ARCH - LDA dst (AddrImm imm_lbl) -#endif -#if i386_TARGET_ARCH - MOV L (OpImm imm_lbl) (OpReg dst) -#endif -#if sparc_TARGET_ARCH - SETHI (HI imm_lbl) dst, - OR False dst (RIImm (LO imm_lbl)) dst -#endif -#if powerpc_TARGET_ARCH - LIS dst (HI imm_lbl), - OR dst dst (RIImm (LO imm_lbl)) -#endif - ] - in - returnNat (Any PtrRep code) - --- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - --- end of machine-"independent" bit; here we go on the rest... - -#if alpha_TARGET_ARCH - -getRegister (StDouble d) - = getNatLabelNCG `thenNat` \ lbl -> - getNewRegNCG PtrRep `thenNat` \ tmp -> - let code dst = mkSeqInstrs [ - SEGMENT DataSegment, - LABEL lbl, - DATA TF [ImmLab (rational d)], - SEGMENT TextSegment, - LDA tmp (AddrImm (ImmCLbl lbl)), - LD TF dst (AddrReg tmp)] - in - returnNat (Any DoubleRep code) - -getRegister (StPrim primop [x]) -- unary PrimOps - = case primop of - IntNegOp -> trivialUCode (NEG Q False) x - - NotOp -> trivialUCode NOT x - - FloatNegOp -> trivialUFCode FloatRep (FNEG TF) x - DoubleNegOp -> trivialUFCode DoubleRep (FNEG TF) x - - OrdOp -> coerceIntCode IntRep x - ChrOp -> chrCode x - - Float2IntOp -> coerceFP2Int x - Int2FloatOp -> coerceInt2FP pr x - Double2IntOp -> coerceFP2Int x - Int2DoubleOp -> coerceInt2FP pr x - - Double2FloatOp -> coerceFltCode x - Float2DoubleOp -> coerceFltCode x - - other_op -> getRegister (StCall fn CCallConv DoubleRep [x]) - where - fn = case other_op of - FloatExpOp -> FSLIT("exp") - FloatLogOp -> FSLIT("log") - FloatSqrtOp -> FSLIT("sqrt") - FloatSinOp -> FSLIT("sin") - FloatCosOp -> FSLIT("cos") - FloatTanOp -> FSLIT("tan") - FloatAsinOp -> FSLIT("asin") - FloatAcosOp -> FSLIT("acos") - FloatAtanOp -> FSLIT("atan") - FloatSinhOp -> FSLIT("sinh") - FloatCoshOp -> FSLIT("cosh") - FloatTanhOp -> FSLIT("tanh") - DoubleExpOp -> FSLIT("exp") - DoubleLogOp -> FSLIT("log") - DoubleSqrtOp -> FSLIT("sqrt") - DoubleSinOp -> FSLIT("sin") - DoubleCosOp -> FSLIT("cos") - DoubleTanOp -> FSLIT("tan") - DoubleAsinOp -> FSLIT("asin") - DoubleAcosOp -> FSLIT("acos") - DoubleAtanOp -> FSLIT("atan") - DoubleSinhOp -> FSLIT("sinh") - DoubleCoshOp -> FSLIT("cosh") - DoubleTanhOp -> FSLIT("tanh") - where - pr = panic "MachCode.getRegister: no primrep needed for Alpha" - -getRegister (StPrim primop [x, y]) -- dyadic PrimOps - = case primop of - CharGtOp -> trivialCode (CMP LTT) y x - CharGeOp -> trivialCode (CMP LE) y x - CharEqOp -> trivialCode (CMP EQQ) x y - CharNeOp -> int_NE_code x y - CharLtOp -> trivialCode (CMP LTT) x y - CharLeOp -> trivialCode (CMP LE) x y - - IntGtOp -> trivialCode (CMP LTT) y x - IntGeOp -> trivialCode (CMP LE) y x - IntEqOp -> trivialCode (CMP EQQ) x y - IntNeOp -> int_NE_code x y - IntLtOp -> trivialCode (CMP LTT) x y - IntLeOp -> trivialCode (CMP LE) x y - - WordGtOp -> trivialCode (CMP ULT) y x - WordGeOp -> trivialCode (CMP ULE) x y - WordEqOp -> trivialCode (CMP EQQ) x y - WordNeOp -> int_NE_code x y - WordLtOp -> trivialCode (CMP ULT) x y - WordLeOp -> trivialCode (CMP ULE) x y - - AddrGtOp -> trivialCode (CMP ULT) y x - AddrGeOp -> trivialCode (CMP ULE) y x - AddrEqOp -> trivialCode (CMP EQQ) x y - AddrNeOp -> int_NE_code x y - AddrLtOp -> trivialCode (CMP ULT) x y - AddrLeOp -> trivialCode (CMP ULE) x y - - FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y - FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y - FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y - FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y - FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y - FloatLeOp -> cmpF_code (FCMP TF LE) NE x y - - DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y - DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y - DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y - DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y - DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y - DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y - - IntAddOp -> trivialCode (ADD Q False) x y - IntSubOp -> trivialCode (SUB Q False) x y - IntMulOp -> trivialCode (MUL Q False) x y - IntQuotOp -> trivialCode (DIV Q False) x y - IntRemOp -> trivialCode (REM Q False) x y - - WordAddOp -> trivialCode (ADD Q False) x y - WordSubOp -> trivialCode (SUB Q False) x y - WordMulOp -> trivialCode (MUL Q False) x y - WordQuotOp -> trivialCode (DIV Q True) x y - WordRemOp -> trivialCode (REM Q True) x y - - FloatAddOp -> trivialFCode FloatRep (FADD TF) x y - FloatSubOp -> trivialFCode FloatRep (FSUB TF) x y - FloatMulOp -> trivialFCode FloatRep (FMUL TF) x y - FloatDivOp -> trivialFCode FloatRep (FDIV TF) x y - - DoubleAddOp -> trivialFCode DoubleRep (FADD TF) x y - DoubleSubOp -> trivialFCode DoubleRep (FSUB TF) x y - DoubleMulOp -> trivialFCode DoubleRep (FMUL TF) x y - DoubleDivOp -> trivialFCode DoubleRep (FDIV TF) x y - - AddrAddOp -> trivialCode (ADD Q False) x y - AddrSubOp -> trivialCode (SUB Q False) x y - AddrRemOp -> trivialCode (REM Q True) x y - - AndOp -> trivialCode AND x y - OrOp -> trivialCode OR x y - XorOp -> trivialCode XOR x y - SllOp -> trivialCode SLL x y - SrlOp -> trivialCode SRL x y - - ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll" - ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra" - ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl" - - FloatPowerOp -> getRegister (StCall FSLIT("pow") CCallConv DoubleRep [x,y]) - DoublePowerOp -> getRegister (StCall FSLIT("pow") CCallConv DoubleRep [x,y]) - where - {- ------------------------------------------------------------ - Some bizarre special code for getting condition codes into - registers. Integer non-equality is a test for equality - followed by an XOR with 1. (Integer comparisons always set - the result register to 0 or 1.) Floating point comparisons of - any kind leave the result in a floating point register, so we - need to wrangle an integer register out of things. - -} - int_NE_code :: StixTree -> StixTree -> NatM Register - - int_NE_code x y - = trivialCode (CMP EQQ) x y `thenNat` \ register -> - getNewRegNCG IntRep `thenNat` \ tmp -> - let - code = registerCode register tmp - src = registerName register tmp - code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst) - in - returnNat (Any IntRep code__2) - - {- ------------------------------------------------------------ - Comments for int_NE_code also apply to cmpF_code - -} - cmpF_code - :: (Reg -> Reg -> Reg -> Instr) - -> Cond - -> StixTree -> StixTree - -> NatM Register - - cmpF_code instr cond x y - = trivialFCode pr instr x y `thenNat` \ register -> - getNewRegNCG DoubleRep `thenNat` \ tmp -> - getNatLabelNCG `thenNat` \ lbl -> - let - code = registerCode register tmp - result = registerName register tmp - - code__2 dst = code . mkSeqInstrs [ - OR zeroh (RIImm (ImmInt 1)) dst, - BF cond result (ImmCLbl lbl), - OR zeroh (RIReg zeroh) dst, - LABEL lbl] - in - returnNat (Any IntRep code__2) - where - pr = panic "trivialU?FCode: does not use PrimRep on Alpha" - ------------------------------------------------------------ - -getRegister (StInd pk mem) - = getAmode mem `thenNat` \ amode -> - let - code = amodeCode amode - src = amodeAddr amode - size = primRepToSize pk - code__2 dst = code . mkSeqInstr (LD size dst src) - in - returnNat (Any pk code__2) - -getRegister (StInt i) - | fits8Bits i - = let - code dst = mkSeqInstr (OR zeroh (RIImm src) dst) - in - returnNat (Any IntRep code) - | otherwise - = let - code dst = mkSeqInstr (LDI Q dst src) - in - returnNat (Any IntRep code) - where - src = ImmInt (fromInteger i) - -getRegister leaf - | maybeToBool imm - = let - code dst = mkSeqInstr (LDA dst (AddrImm imm__2)) - in - returnNat (Any PtrRep code) - where - imm = maybeImm leaf - imm__2 = case imm of Just x -> x - -#endif /* alpha_TARGET_ARCH */ - --- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#if i386_TARGET_ARCH - -getRegister (StFloat f) - = getNatLabelNCG `thenNat` \ lbl -> - let code dst = toOL [ - SEGMENT DataSegment, - LABEL lbl, - DATA F [ImmFloat f], - SEGMENT TextSegment, - GLD F (ImmAddr (ImmCLbl lbl) 0) dst - ] - in - returnNat (Any FloatRep code) - - -getRegister (StDouble d) - - | d == 0.0 - = let code dst = unitOL (GLDZ dst) - in returnNat (Any DoubleRep code) - - | d == 1.0 - = let code dst = unitOL (GLD1 dst) - in returnNat (Any DoubleRep code) - - | otherwise - = getNatLabelNCG `thenNat` \ lbl -> - let code dst = toOL [ - SEGMENT DataSegment, - LABEL lbl, - DATA DF [ImmDouble d], - SEGMENT TextSegment, - GLD DF (ImmAddr (ImmCLbl lbl) 0) dst - ] - in - returnNat (Any DoubleRep code) - - -getRegister (StMachOp mop [x]) -- unary MachOps - = case mop of - MO_NatS_Neg -> trivialUCode (NEGI L) x - MO_Nat_Not -> trivialUCode (NOT L) x - MO_32U_to_8U -> trivialUCode (AND L (OpImm (ImmInt 255))) x - - MO_Flt_Neg -> trivialUFCode FloatRep (GNEG F) x - MO_Dbl_Neg -> trivialUFCode DoubleRep (GNEG DF) x - - MO_Flt_Sqrt -> trivialUFCode FloatRep (GSQRT F) x - MO_Dbl_Sqrt -> trivialUFCode DoubleRep (GSQRT DF) x - - MO_Flt_Sin -> trivialUFCode FloatRep (GSIN F) x - MO_Dbl_Sin -> trivialUFCode DoubleRep (GSIN DF) x - - MO_Flt_Cos -> trivialUFCode FloatRep (GCOS F) x - MO_Dbl_Cos -> trivialUFCode DoubleRep (GCOS DF) x - - MO_Flt_Tan -> trivialUFCode FloatRep (GTAN F) x - MO_Dbl_Tan -> trivialUFCode DoubleRep (GTAN DF) x - - MO_Flt_to_NatS -> coerceFP2Int FloatRep x - MO_NatS_to_Flt -> coerceInt2FP FloatRep x - MO_Dbl_to_NatS -> coerceFP2Int DoubleRep x - MO_NatS_to_Dbl -> coerceInt2FP DoubleRep x - - -- Conversions which are a nop on x86 - MO_32U_to_NatS -> conversionNop IntRep x - MO_32S_to_NatS -> conversionNop IntRep x - MO_NatS_to_32U -> conversionNop WordRep x - MO_32U_to_NatU -> conversionNop WordRep x - - MO_NatU_to_NatS -> conversionNop IntRep x - MO_NatS_to_NatU -> conversionNop WordRep x - MO_NatP_to_NatU -> conversionNop WordRep x - MO_NatU_to_NatP -> conversionNop PtrRep x - MO_NatS_to_NatP -> conversionNop PtrRep x - MO_NatP_to_NatS -> conversionNop IntRep x - - MO_Dbl_to_Flt -> conversionNop FloatRep x - MO_Flt_to_Dbl -> conversionNop DoubleRep x - - -- sign-extending widenings - MO_8U_to_NatU -> integerExtend False 24 x - MO_8S_to_NatS -> integerExtend True 24 x - MO_16U_to_NatU -> integerExtend False 16 x - MO_16S_to_NatS -> integerExtend True 16 x - MO_8U_to_32U -> integerExtend False 24 x - - other_op - -> getRegister ( - (if is_float_op then demote else id) - (StCall (Left fn) CCallConv DoubleRep - [(if is_float_op then promote else id) x]) - ) - where - integerExtend signed nBits x - = getRegister ( - StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr) - [StMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits] - ) - - conversionNop new_rep expr - = getRegister expr `thenNat` \ e_code -> - returnNat (swizzleRegisterRep e_code new_rep) - - promote x = StMachOp MO_Flt_to_Dbl [x] - demote x = StMachOp MO_Dbl_to_Flt [x] - (is_float_op, fn) - = case mop of - MO_Flt_Exp -> (True, FSLIT("exp")) - MO_Flt_Log -> (True, FSLIT("log")) - - MO_Flt_Asin -> (True, FSLIT("asin")) - MO_Flt_Acos -> (True, FSLIT("acos")) - MO_Flt_Atan -> (True, FSLIT("atan")) - - MO_Flt_Sinh -> (True, FSLIT("sinh")) - MO_Flt_Cosh -> (True, FSLIT("cosh")) - MO_Flt_Tanh -> (True, FSLIT("tanh")) - - MO_Dbl_Exp -> (False, FSLIT("exp")) - MO_Dbl_Log -> (False, FSLIT("log")) - - MO_Dbl_Asin -> (False, FSLIT("asin")) - MO_Dbl_Acos -> (False, FSLIT("acos")) - MO_Dbl_Atan -> (False, FSLIT("atan")) - - MO_Dbl_Sinh -> (False, FSLIT("sinh")) - MO_Dbl_Cosh -> (False, FSLIT("cosh")) - MO_Dbl_Tanh -> (False, FSLIT("tanh")) - - other -> pprPanic "getRegister(x86) - binary StMachOp (2)" - (pprMachOp mop) - - -getRegister (StMachOp mop [x, y]) -- dyadic MachOps - = case mop of - MO_32U_Gt -> condIntReg GTT x y - MO_32U_Ge -> condIntReg GE x y - MO_32U_Eq -> condIntReg EQQ x y - MO_32U_Ne -> condIntReg NE x y - MO_32U_Lt -> condIntReg LTT x y - MO_32U_Le -> condIntReg LE x y - - MO_Nat_Eq -> condIntReg EQQ x y - MO_Nat_Ne -> condIntReg NE x y - - MO_NatS_Gt -> condIntReg GTT x y - MO_NatS_Ge -> condIntReg GE x y - MO_NatS_Lt -> condIntReg LTT x y - MO_NatS_Le -> condIntReg LE x y - - MO_NatU_Gt -> condIntReg GU x y - MO_NatU_Ge -> condIntReg GEU x y - MO_NatU_Lt -> condIntReg LU x y - MO_NatU_Le -> condIntReg LEU x y - - MO_Flt_Gt -> condFltReg GTT x y - MO_Flt_Ge -> condFltReg GE x y - MO_Flt_Eq -> condFltReg EQQ x y - MO_Flt_Ne -> condFltReg NE x y - MO_Flt_Lt -> condFltReg LTT x y - MO_Flt_Le -> condFltReg LE x y - - MO_Dbl_Gt -> condFltReg GTT x y - MO_Dbl_Ge -> condFltReg GE x y - MO_Dbl_Eq -> condFltReg EQQ x y - MO_Dbl_Ne -> condFltReg NE x y - MO_Dbl_Lt -> condFltReg LTT x y - MO_Dbl_Le -> condFltReg LE x y - - MO_Nat_Add -> add_code L x y - MO_Nat_Sub -> sub_code L x y - MO_NatS_Quot -> trivialCode (IQUOT L) Nothing x y - MO_NatS_Rem -> trivialCode (IREM L) Nothing x y - MO_NatU_Quot -> trivialCode (QUOT L) Nothing x y - MO_NatU_Rem -> trivialCode (REM L) Nothing x y - MO_NatS_Mul -> let op = IMUL L in trivialCode op (Just op) x y - MO_NatU_Mul -> let op = MUL L in trivialCode op (Just op) x y - MO_NatS_MulMayOflo -> imulMayOflo x y - - MO_Flt_Add -> trivialFCode FloatRep GADD x y - MO_Flt_Sub -> trivialFCode FloatRep GSUB x y - MO_Flt_Mul -> trivialFCode FloatRep GMUL x y - MO_Flt_Div -> trivialFCode FloatRep GDIV x y - - MO_Dbl_Add -> trivialFCode DoubleRep GADD x y - MO_Dbl_Sub -> trivialFCode DoubleRep GSUB x y - MO_Dbl_Mul -> trivialFCode DoubleRep GMUL x y - MO_Dbl_Div -> trivialFCode DoubleRep GDIV x y - - MO_Nat_And -> let op = AND L in trivialCode op (Just op) x y - MO_Nat_Or -> let op = OR L in trivialCode op (Just op) x y - MO_Nat_Xor -> let op = XOR L in trivialCode op (Just op) x y - - {- Shift ops on x86s have constraints on their source, it - either has to be Imm, CL or 1 - => trivialCode's is not restrictive enough (sigh.) - -} - MO_Nat_Shl -> shift_code (SHL L) x y {-False-} - MO_Nat_Shr -> shift_code (SHR L) x y {-False-} - MO_Nat_Sar -> shift_code (SAR L) x y {-False-} - - MO_Flt_Pwr -> getRegister (demote - (StCall (Left FSLIT("pow")) CCallConv DoubleRep - [promote x, promote y]) - ) - MO_Dbl_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep - [x, y]) - other -> pprPanic "getRegister(x86) - binary StMachOp (1)" (pprMachOp mop) - where - promote x = StMachOp MO_Flt_to_Dbl [x] - demote x = StMachOp MO_Dbl_to_Flt [x] - - -------------------- - imulMayOflo :: StixExpr -> StixExpr -> NatM Register - imulMayOflo a1 a2 - = getNewRegNCG IntRep `thenNat` \ t1 -> - getNewRegNCG IntRep `thenNat` \ t2 -> - getNewRegNCG IntRep `thenNat` \ res_lo -> - getNewRegNCG IntRep `thenNat` \ res_hi -> - getRegister a1 `thenNat` \ reg1 -> - getRegister a2 `thenNat` \ reg2 -> - let code1 = registerCode reg1 t1 - code2 = registerCode reg2 t2 - src1 = registerName reg1 t1 - src2 = registerName reg2 t2 - code dst = code1 `appOL` code2 `appOL` - toOL [ - MOV L (OpReg src1) (OpReg res_hi), - MOV L (OpReg src2) (OpReg res_lo), - IMUL64 res_hi res_lo, -- result in res_hi:res_lo - SAR L (ImmInt 31) (OpReg res_lo), -- sign extend lower part - SUB L (OpReg res_hi) (OpReg res_lo), -- compare against upper - MOV L (OpReg res_lo) (OpReg dst) - -- dst==0 if high part == sign extended low part - ] - in - returnNat (Any IntRep code) - - -------------------- - shift_code :: (Imm -> Operand -> Instr) - -> StixExpr - -> StixExpr - -> NatM Register - - {- Case1: shift length as immediate -} - -- Code is the same as the first eq. for trivialCode -- sigh. - shift_code instr x y{-amount-} - | maybeToBool imm - = getRegister x `thenNat` \ regx -> - let mkcode dst - = if isAny regx - then registerCodeA regx dst `bind` \ code_x -> - code_x `snocOL` - instr imm__2 (OpReg dst) - else registerCodeF regx `bind` \ code_x -> - registerNameF regx `bind` \ r_x -> - code_x `snocOL` - MOV L (OpReg r_x) (OpReg dst) `snocOL` - instr imm__2 (OpReg dst) - in - returnNat (Any IntRep mkcode) - where - imm = maybeImm y - imm__2 = case imm of Just x -> x - - {- Case2: shift length is complex (non-immediate) -} - -- Since ECX is always used as a spill temporary, we can't - -- use it here to do non-immediate shifts. No big deal -- - -- they are only very rare, and we can use an equivalent - -- test-and-jump sequence which doesn't use ECX. - -- DO NOT REPLACE THIS CODE WITH THE "OBVIOUS" shl/shr/sar CODE, - -- SINCE IT WILL CAUSE SERIOUS PROBLEMS WITH THE SPILLER - shift_code instr x y{-amount-} - = getRegister x `thenNat` \ register1 -> - getRegister y `thenNat` \ register2 -> - getNatLabelNCG `thenNat` \ lbl_test3 -> - getNatLabelNCG `thenNat` \ lbl_test2 -> - getNatLabelNCG `thenNat` \ lbl_test1 -> - getNatLabelNCG `thenNat` \ lbl_test0 -> - getNatLabelNCG `thenNat` \ lbl_after -> - getNewRegNCG IntRep `thenNat` \ tmp -> - let code__2 dst - = let src_val = registerName register1 dst - code_val = registerCode register1 dst - src_amt = registerName register2 tmp - code_amt = registerCode register2 tmp - r_dst = OpReg dst - r_tmp = OpReg tmp - in - code_amt `snocOL` - MOV L (OpReg src_amt) r_tmp `appOL` - code_val `snocOL` - MOV L (OpReg src_val) r_dst `appOL` - toOL [ - COMMENT (mkFastString "begin shift sequence"), - MOV L (OpReg src_val) r_dst, - MOV L (OpReg src_amt) r_tmp, - - BT L (ImmInt 4) r_tmp, - JXX GEU lbl_test3, - instr (ImmInt 16) r_dst, - - LABEL lbl_test3, - BT L (ImmInt 3) r_tmp, - JXX GEU lbl_test2, - instr (ImmInt 8) r_dst, - - LABEL lbl