diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2012-08-29 07:35:23 +0100 |
|---|---|---|
| committer | Simon Peyton Jones <simonpj@microsoft.com> | 2012-08-29 07:35:23 +0100 |
| commit | 72e46baf25f757b24e3eb9ebb8f5694d8ca8722e (patch) | |
| tree | 64aff42bcfb92a5b6894ee5098d40b010227ca7e /compiler | |
| parent | 1bbdbe55970310f92122fb5321b65705646835b4 (diff) | |
| parent | 41448969dad90e479e4eac3721fc5d5dd4968885 (diff) | |
| download | haskell-72e46baf25f757b24e3eb9ebb8f5694d8ca8722e.tar.gz | |
Merge branch 'master' of http://darcs.haskell.org/ghc
Diffstat (limited to 'compiler')
35 files changed, 945 insertions, 1825 deletions
diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index cd8dc6c711..8a10724524 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -47,6 +47,7 @@ import Lexer import ForeignCall import Module +import Platform import Literal import Unique import UniqFM @@ -65,7 +66,7 @@ import Var import Control.Monad import Data.Array -import Data.Char ( ord ) +import Data.Char ( ord ) import System.Exit #include "HsVersions.h" @@ -74,76 +75,76 @@ import System.Exit %expect 0 %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_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) } - 'never' { L _ (CmmT_never) } - 'prim' { L _ (CmmT_prim) } - 'return' { L _ (CmmT_return) } - 'returns' { L _ (CmmT_returns) } - '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) } - 'gcptr' { L _ (CmmT_gcptr) } - - GLOBALREG { L _ (CmmT_GlobalReg $$) } - NAME { L _ (CmmT_Name $$) } - STRING { L _ (CmmT_String $$) } - INT { L _ (CmmT_Int $$) } - FLOAT { L _ (CmmT_Float $$) } + '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) } + 'never' { L _ (CmmT_never) } + 'prim' { L _ (CmmT_prim) } + 'return' { L _ (CmmT_return) } + 'returns' { L _ (CmmT_returns) } + '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) } + 'gcptr' { L _ (CmmT_gcptr) } + + 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 } @@ -151,8 +152,8 @@ import System.Exit %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 '||' -- non-std extension, called %disjoin in C-- +%right '&&' -- non-std extension, called %conjoin in C-- %right '!' %nonassoc '>=' '>' '<=' '<' '!=' '==' %left '|' @@ -165,102 +166,102 @@ import System.Exit %% -cmm :: { ExtCode } - : {- empty -} { return () } - | cmmtop cmm { do $1; $2 } +cmm :: { ExtCode } + : {- empty -} { return () } + | cmmtop cmm { do $1; $2 } -cmmtop :: { ExtCode } - : cmmproc { $1 } - | cmmdata { $1 } - | decl { $1 } - | 'CLOSURE' '(' NAME ',' NAME lits ')' ';' - {% withThisPackage $ \pkg -> - do lits <- sequence $6; - staticClosure pkg $3 $5 (map getLit lits) } +cmmtop :: { ExtCode } + : cmmproc { $1 } + | cmmdata { $1 } + | decl { $1 } + | 'CLOSURE' '(' NAME ',' NAME lits ')' ';' + {% withThisPackage $ \pkg -> + do lits <- sequence $6; + staticClosure pkg $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 +-- * 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 '{' data_label statics '}' - { do lbl <- $4; - ss <- sequence $5; - code (emitDecl (CmmData (section $2) (Statics lbl $ concat ss))) } + : 'section' STRING '{' data_label statics '}' + { do lbl <- $4; + ss <- sequence $5; + code (emitDecl (CmmData (section $2) (Statics lbl $ concat ss))) } data_label :: { ExtFCode CLabel } - : NAME ':' - {% withThisPackage $ \pkg -> - return (mkCmmDataLabel pkg $1) } - -statics :: { [ExtFCode [CmmStatic]] } - : {- empty -} { [] } - | static statics { $1 : $2 } - + : NAME ':' + {% withThisPackage $ \pkg -> + return (mkCmmDataLabel pkg $1) } + +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] } - : type expr ';' { do e <- $2; - return [CmmStaticLit (getLit e)] } - | type ';' { return [CmmUninitialised - (widthInBytes (typeWidth $1))] } - | 'bits8' '[' ']' STRING ';' { return [mkString $4] } - | 'bits8' '[' INT ']' ';' { return [CmmUninitialised - (fromIntegral $3)] } - | typenot8 '[' INT ']' ';' { return [CmmUninitialised - (widthInBytes (typeWidth $1) * - fromIntegral $3)] } - | 'CLOSURE' '(' NAME lits ')' - { do { lits <- sequence $4 +static :: { ExtFCode [CmmStatic] } + : type expr ';' { do e <- $2; + return [CmmStaticLit (getLit e)] } + | type ';' { return [CmmUninitialised + (widthInBytes (typeWidth $1))] } + | 'bits8' '[' ']' STRING ';' { return [mkString $4] } + | 'bits8' '[' INT ']' ';' { return [CmmUninitialised + (fromIntegral $3)] } + | typenot8 '[' INT ']' ';' { return [CmmUninitialised + (widthInBytes (typeWidth $1) * + fromIntegral $3)] } + | 'CLOSURE' '(' NAME lits ')' + { do { lits <- sequence $4 ; dflags <- getDynFlags - ; return $ map CmmStaticLit $ + ; return $ map CmmStaticLit $ mkStaticClosure dflags (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData) -- mkForeignLabel because these are only used -- for CHARLIKE and INTLIKE closures in the RTS. dontCareCCS (map getLit lits) [] [] [] } } - -- arrays of closures required for the CHARLIKE & INTLIKE arrays + -- arrays of closures required for the CHARLIKE & INTLIKE arrays -lits :: { [ExtFCode CmmExpr] } - : {- empty -} { [] } - | ',' expr lits { $2 : $3 } +lits :: { [ExtFCode CmmExpr] } + : {- empty -} { [] } + | ',' expr lits { $2 : $3 } cmmproc :: { ExtCode } -- TODO: add real SRT/info tables to parsed Cmm : info maybe_formals_without_hints '{' body '}' { do ((entry_ret_label, info, live, formals), stmts) <- - getCgStmtsEC' $ loopDecls $ do { - (entry_ret_label, info, live) <- $1; - formals <- sequence $2; + getCgStmtsEC' $ loopDecls $ do { + (entry_ret_label, info, live) <- $1; + formals <- sequence $2; $4; return (entry_ret_label, info, live, formals) } - blks <- code (cgStmtsToBlocks stmts) + blks <- code (cgStmtsToBlocks stmts) code (emitInfoTableAndCode entry_ret_label info formals blks) } - | info maybe_formals_without_hints ';' - { do (entry_ret_label, info, live) <- $1; - formals <- sequence $2; + | info maybe_formals_without_hints ';' + { do (entry_ret_label, info, live) <- $1; + formals <- sequence $2; code (emitInfoTableAndCode entry_ret_label info formals []) } | NAME maybe_formals_without_hints '{' body '}' - {% withThisPackage $ \pkg -> - do newFunctionName $1 pkg + {% withThisPackage $ \pkg -> + do newFunctionName $1 pkg (formals, stmts) <- - getCgStmtsEC' $ loopDecls $ do { - formals <- sequence $2; + getCgStmtsEC' $ loopDecls $ do { + formals <- sequence $2; $4; return formals } - blks <- code (cgStmtsToBlocks stmts) + blks <- code (cgStmtsToBlocks stmts) code (emitProc Nothing (mkCmmCodeLabel pkg $1) formals blks) } -info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } - : 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')' - -- ptrs, nptrs, closure type, description, type - {% withThisPackage $ \pkg -> +info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } + : 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')' + -- ptrs, nptrs, closure type, description, type + {% withThisPackage $ \pkg -> do dflags <- getDynFlags let prof = profilingInfo dflags $11 $13 rep = mkRTSRep (fromIntegral $9) $ @@ -269,14 +270,14 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } -- not really Thunk, but that makes the info table -- we want. return (mkCmmEntryLabel pkg $3, - CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 - , cit_rep = rep - , cit_prof = prof, cit_srt = NoC_SRT }, - []) } - - | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')' - -- ptrs, nptrs, closure type, description, type, fun type - {% withThisPackage $ \pkg -> + CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 + , cit_rep = rep + , cit_prof = prof, cit_srt = NoC_SRT }, + []) } + + | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')' + -- ptrs, nptrs, closure type, description, type, fun type + {% withThisPackage $ \pkg -> do dflags <- getDynFlags let prof = profilingInfo dflags $11 $13 ty = Fun 0 (ArgSpec (fromIntegral $15)) @@ -285,340 +286,340 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } mkHeapRep dflags False (fromIntegral $5) (fromIntegral $7) ty return (mkCmmEntryLabel pkg $3, - CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 - , cit_rep = rep - , cit_prof = prof, cit_srt = NoC_SRT }, - []) } - -- we leave most of the fields zero here. This is only used - -- to generate the BCO info table in the RTS at the moment. + CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 + , cit_rep = rep + , cit_prof = prof, cit_srt = NoC_SRT }, + []) } + -- we leave most of the fields zero here. This is only used + -- to generate the BCO info table in the RTS at the moment. | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')' - -- ptrs, nptrs, tag, closure type, description, type - {% withThisPackage $ \pkg -> + -- ptrs, nptrs, tag, closure type, description, type + {% withThisPackage $ \pkg -> do dflags <- getDynFlags let prof = profilingInfo dflags $13 $15 ty = Constr (fromIntegral $9) -- Tag - (stringToWord8s $13) + (stringToWord8s $13) rep = mkRTSRep (fromIntegral $11) $ mkHeapRep dflags False (fromIntegral $5) (fromIntegral $7) ty return (mkCmmEntryLabel pkg $3, - CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 - , cit_rep = rep - , cit_prof = prof, cit_srt = NoC_SRT }, - []) } - - -- If profiling is on, this string gets duplicated, - -- but that's the way the old code did it we can fix it some other time. - - | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')' - -- selector, closure type, description, type - {% withThisPackage $ \pkg -> + CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 + , cit_rep = rep + , cit_prof = prof, cit_srt = NoC_SRT }, + []) } + + -- If profiling is on, this string gets duplicated, + -- but that's the way the old code did it we can fix it some other time. + + | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')' + -- selector, closure type, description, type + {% withThisPackage $ \pkg -> do dflags <- getDynFlags let prof = profilingInfo dflags $9 $11 ty = ThunkSelector (fromIntegral $5) rep = mkRTSRep (fromIntegral $7) $ mkHeapRep dflags False 0 0 ty return (mkCmmEntryLabel pkg $3, - CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 - , cit_rep = rep - , cit_prof = prof, cit_srt = NoC_SRT }, - []) } - - | 'INFO_TABLE_RET' '(' NAME ',' INT ')' - -- closure type (no live regs) - {% withThisPackage $ \pkg -> - do let prof = NoProfilingInfo + CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 + , cit_rep = rep + , cit_prof = prof, cit_srt = NoC_SRT }, + []) } + + | 'INFO_TABLE_RET' '(' NAME ',' INT ')' + -- closure type (no live regs) + {% withThisPackage $ \pkg -> + do let prof = NoProfilingInfo rep = mkRTSRep (fromIntegral $5) $ mkStackRep [] return (mkCmmRetLabel pkg $3, - CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 - , cit_rep = rep - , cit_prof = prof, cit_srt = NoC_SRT }, - []) } - - | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals_without_hints0 ')' - -- closure type, live regs - {% withThisPackage $ \pkg -> - do live <- sequence (map (liftM Just) $7) - let prof = NoProfilingInfo + CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 + , cit_rep = rep + , cit_prof = prof, cit_srt = NoC_SRT }, + []) } + + | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals_without_hints0 ')' + -- closure type, live regs + {% withThisPackage $ \pkg -> + do live <- sequence (map (liftM Just) $7) + let prof = NoProfilingInfo bitmap = mkLiveness live rep = mkRTSRep (fromIntegral $5) $ mkStackRep bitmap return (mkCmmRetLabel pkg $3, - CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 - , cit_rep = rep - , cit_prof = prof, cit_srt = NoC_SRT }, - []) } + CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 + , cit_rep = rep + , cit_prof = prof, cit_srt = NoC_SRT }, + []) } -body :: { ExtCode } - : {- empty -} { return () } - | decl body { do $1; $2 } - | stmt body { do $1; $2 } +body :: { ExtCode } + : {- empty -} { return () } + | decl body { do $1; $2 } + | stmt body { do $1; $2 } -decl :: { ExtCode } - : type names ';' { mapM_ (newLocal $1) $2 } - | 'import' importNames ';' { mapM_ newImport $2 } - | 'export' names ';' { return () } -- ignore exports +decl :: { ExtCode } + : type names ';' { mapM_ (newLocal $1) $2 } + | 'import' importNames ';' { mapM_ newImport $2 } + | 'export' names ';' { return () } -- ignore exports -- an imported function name, with optional packageId -importNames - :: { [(FastString, CLabel)] } - : importName { [$1] } - | importName ',' importNames { $1 : $3 } - +importNames + :: { [(FastString, CLabel)] } + : importName { [$1] } + | importName ',' importNames { $1 : $3 } + importName - :: { (FastString, CLabel) } - - -- A label imported without an explicit packageId. - -- These are taken to come frome some foreign, unnamed package. - : NAME - { ($1, mkForeignLabel $1 Nothing ForeignLabelInExternalPackage IsFunction) } - - -- A label imported with an explicit packageId. - | STRING NAME - { ($2, mkCmmCodeLabel (fsToPackageId (mkFastString $1)) $2) } - - -names :: { [FastString] } - : NAME { [$1] } - | NAME ',' names { $1 : $3 } - -stmt :: { ExtCode } - : ';' { nopEC } - - | NAME ':' - { do l <- newLabel $1; code (labelC l) } - - | lreg '=' expr ';' - { do reg <- $1; e <- $3; stmtEC (CmmAssign reg e) } - | type '[' expr ']' '=' expr ';' - { doStore $1 $3 $6 } - - -- Gah! We really want to say "maybe_results" but that causes - -- a shift/reduce conflict with assignment. We either - -- we expand out the no-result and single result cases or - -- we tweak the syntax to avoid the conflict. The later - -- option is taken here because the other way would require - -- multiple levels of expanding and get unwieldy. - | maybe_results 'foreign' STRING expr '(' cmm_hint_exprs0 ')' safety vols opt_never_returns ';' - {% foreignCall $3 $1 $4 $6 $9 $8 $10 } - | maybe_results 'prim' '%' NAME '(' cmm_hint_exprs0 ')' safety vols ';' - {% primCall $1 $4 $6 $9 $8 } - -- 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 '}' - { do as <- sequence $5; doSwitch $2 $3 as $6 } - | 'goto' NAME ';' - { do l <- lookupLabel $2; stmtEC (CmmBranch l) } - | 'jump' expr vols ';' - { do e <- $2; stmtEC (CmmJump e $3) } + :: { (FastString, CLabel) } + + -- A label imported without an explicit packageId. + -- These are taken to come frome some foreign, unnamed package. + : NAME + { ($1, mkForeignLabel $1 Nothing ForeignLabelInExternalPackage IsFunction) } + + -- A label imported with an explicit packageId. + | STRING NAME + { ($2, mkCmmCodeLabel (fsToPackageId (mkFastString $1)) $2) } + + +names :: { [FastString] } + : NAME { [$1] } + | NAME ',' names { $1 : $3 } + +stmt :: { ExtCode } + : ';' { nopEC } + + | NAME ':' + { do l <- newLabel $1; code (labelC l) } + + | lreg '=' expr ';' + { do reg <- $1; e <- $3; stmtEC (CmmAssign reg e) } + | type '[' expr ']' '=' expr ';' + { doStore $1 $3 $6 } + + -- Gah! We really want to say "maybe_results" but that causes + -- a shift/reduce conflict with assignment. We either + -- we expand out the no-result and single result cases or + -- we tweak the syntax to avoid the conflict. The later + -- option is taken here because the other way would require + -- multiple levels of expanding and get unwieldy. + | maybe_results 'foreign' STRING expr '(' cmm_hint_exprs0 ')' safety vols opt_never_returns ';' + {% foreignCall $3 $1 $4 $6 $9 $8 $10 } + | maybe_results 'prim' '%' NAME '(' cmm_hint_exprs0 ')' safety vols ';' + {% primCall $1 $4 $6 $9 $8 } + -- 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 '}' + { do as <- sequence $5; doSwitch $2 $3 as $6 } + | 'goto' NAME ';' + { do l <- lookupLabel $2; stmtEC (CmmBranch l) } + | 'jump' expr vols ';' + { do e <- $2; stmtEC (CmmJump e $3) } | 'return' ';' - { stmtEC CmmReturn } - | 'if' bool_expr 'goto' NAME - { do l <- lookupLabel $4; cmmRawIf $2 l } - | 'if' bool_expr '{' body '}' else - { cmmIfThenElse $2 $4 $6 } + { stmtEC CmmReturn } + | 'if' bool_expr 'goto' NAME + { do l <- lookupLabel $4; cmmRawIf $2 l } + | 'if' bool_expr '{' body '}' else + { cmmIfThenElse $2 $4 $6 } opt_never_returns :: { CmmReturnInfo } : { CmmMayReturn } | 'never' 'returns' { CmmNeverReturns } bool_expr :: { ExtFCode BoolExpr } - : bool_op { $1 } - | expr { do e <- $1; return (BoolTest e) } + : 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 } + : 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? safety :: { CmmSafety } - : {- empty -} { CmmUnsafe } -- Default may change soon - | STRING {% parseSafety $1 } + : {- empty -} { CmmUnsafe } -- Default may change soon + | STRING {% parseSafety $1 } -- This is not C-- syntax. What to do? -vols :: { Maybe [GlobalReg] } - : {- empty -} { Nothing } - | '[' ']' { Just [] } - | '[' globals ']' { Just $2 } +vols :: { Maybe [GlobalReg] } + : {- empty -} { Nothing } + | '[' ']' { Just [] } + | '[' globals ']' { Just $2 } globals :: { [GlobalReg] } - : GLOBALREG { [$1] } - | GLOBALREG ',' globals { $1 : $3 } + : GLOBALREG { [$1] } + | GLOBALREG ',' globals { $1 : $3 } maybe_range :: { Maybe (Int,Int) } - : '[' INT '..' INT ']' { Just (fromIntegral $2, fromIntegral $4) } - | {- empty -} { Nothing } + : '[' INT '..' INT ']' { Just (fromIntegral $2, fromIntegral $4) } + | {- empty -} { Nothing } -arms :: { [ExtFCode ([Int],Either BlockId ExtCode)] } - : {- empty -} { [] } - | arm arms { $1 : $2 } +arms :: { [ExtFCode ([Int],Either BlockId ExtCode)] } + : {- empty -} { [] } + | arm arms { $1 : $2 } -arm :: { ExtFCode ([Int],Either BlockId ExtCode) } - : 'case' ints ':' arm_body { do b <- $4; return ($2, b) } +arm :: { ExtFCode ([Int],Either BlockId ExtCode) } + : 'case' ints ':' arm_body { do b <- $4; return ($2, b) } arm_body :: { ExtFCode (Either BlockId ExtCode) } - : '{' body '}' { return (Right $2) } - | 'goto' NAME ';' { do l <- lookupLabel $2; return (Left l) } + : '{' body '}' { return (Right $2) } + | 'goto' NAME ';' { do l <- lookupLabel $2; return (Left l) } -ints :: { [Int] } - : INT { [ fromIntegral $1 ] } - | INT ',' ints { fromIntegral $1 : $3 } +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 } + : 'default' ':' '{' body '}' { Just $4 } + -- taking a few liberties with the C-- syntax here; C-- doesn't have + -- 'default' branches + | {- empty -} { Nothing } -- Note: OldCmm doesn't support a first class 'else' statement, though -- CmmNode does. -else :: { ExtCode } - : {- empty -} { nopEC } - | 'else' '{' body '}' { $3 } +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 (typeWidth $2))) } - | FLOAT maybe_ty { return (CmmLit (CmmFloat $1 (typeWidth $2))) } - | STRING { do s <- code (newStringCLit $1); - return (CmmLit s) } - | reg { $1 } - | type '[' expr ']' { do e <- $3; return (CmmLoad e $1) } - | '%' NAME '(' exprs0 ')' {% exprOp $2 $4 } - | '(' expr ')' { $2 } +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 (typeWidth $2))) } + | FLOAT maybe_ty { return (CmmLit (CmmFloat $1 (typeWidth $2))) } + | STRING { do s <- code (newStringCLit $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 :: { CmmType } - : {- empty -} { bWord } - | '::' type { $2 } + : {- empty -} { bWord } + | '::' type { $2 } maybe_actuals :: { [ExtFCode HintedCmmActual] } - : {- empty -} { [] } - | '(' cmm_hint_exprs0 ')' { $2 } + : {- empty -} { [] } + | '(' cmm_hint_exprs0 ')' { $2 } cmm_hint_exprs0 :: { [ExtFCode HintedCmmActual] } - : {- empty -} { [] } - | cmm_hint_exprs { $1 } + : {- empty -} { [] } + | cmm_hint_exprs { $1 } cmm_hint_exprs :: { [ExtFCode HintedCmmActual] } - : cmm_hint_expr { [$1] } - | cmm_hint_expr ',' cmm_hint_exprs { $1 : $3 } + : cmm_hint_expr { [$1] } + | cmm_hint_expr ',' cmm_hint_exprs { $1 : $3 } cmm_hint_expr :: { ExtFCode HintedCmmActual } - : expr { do e <- $1; return (CmmHinted e (inferCmmHint e)) } - | expr STRING {% do h <- parseCmmHint $2; - return $ do - e <- $1; return (CmmHinted e h) } + : expr { do e <- $1; return (CmmHinted e (inferCmmHint e)) } + | expr STRING {% do h <- parseCmmHint $2; + return $ do + e <- $1; return (CmmHinted e h) } exprs0 :: { [ExtFCode CmmExpr] } - : {- empty -} { [] } - | exprs { $1 } + : {- empty -} { [] } + | exprs { $1 } -exprs :: { [ExtFCode CmmExpr] } - : expr { [ $1 ] } - | expr ',' exprs { $1 : $3 } +exprs :: { [ExtFCode CmmExpr] } + : expr { [ $1 ] } + | expr ',' exprs { $1 : $3 } -reg :: { ExtFCode CmmExpr } - : NAME { lookupName $1 } - | GLOBALREG { return (CmmReg (CmmGlobal $1)) } +reg :: { ExtFCode CmmExpr } + : NAME { lookupName $1 } + | GLOBALREG { return (CmmReg (CmmGlobal $1)) } maybe_results :: { [ExtFCode HintedCmmFormal] } - : {- empty -} { [] } - | '(' cmm_formals ')' '=' { $2 } + : {- empty -} { [] } + | '(' cmm_formals ')' '=' { $2 } cmm_formals :: { [ExtFCode HintedCmmFormal] } - : cmm_formal { [$1] } - | cmm_formal ',' { [$1] } - | cmm_formal ',' cmm_formals { $1 : $3 } + : cmm_formal { [$1] } + | cmm_formal ',' { [$1] } + | cmm_formal ',' cmm_formals { $1 : $3 } cmm_formal :: { ExtFCode HintedCmmFormal } - : local_lreg { do e <- $1; return (CmmHinted e (inferCmmHint (CmmReg (CmmLocal e)))) } - | STRING local_lreg {% do h <- parseCmmHint $1; - return $ do - e <- $2; return (CmmHinted e h) } + : local_lreg { do e <- $1; return (CmmHinted e (inferCmmHint (CmmReg (CmmLocal e)))) } + | STRING local_lreg {% do h <- parseCmmHint $1; + return $ do + e <- $2; return (CmmHinted e h) } local_lreg :: { ExtFCode LocalReg } - : NAME { do e <- lookupName $1; - return $ - case e of - CmmReg (CmmLocal r) -> r - other -> pprPanic "CmmParse:" (ftext $1 <> text " not a local register") } - -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) } + : NAME { do e <- lookupName $1; + return $ + case e of + CmmReg (CmmLocal r) -> r + other -> pprPanic "CmmParse:" (ftext $1 <> text " not a local register") } + +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) } maybe_formals_without_hints :: { [ExtFCode LocalReg] } - : {- empty -} { [] } - | '(' formals_without_hints0 ')' { $2 } + : {- empty -} { [] } + | '(' formals_without_hints0 ')' { $2 } formals_without_hints0 :: { [ExtFCode LocalReg] } - : {- empty -} { [] } - | formals_without_hints { $1 } + : {- empty -} { [] } + | formals_without_hints { $1 } formals_without_hints :: { [ExtFCode LocalReg] } - : formal_without_hint ',' { [$1] } - | formal_without_hint { [$1] } - | formal_without_hint ',' formals_without_hints { $1 : $3 } + : formal_without_hint ',' { [$1] } + | formal_without_hint { [$1] } + | formal_without_hint ',' formals_without_hints { $1 : $3 } formal_without_hint :: { ExtFCode LocalReg } - : type NAME { newLocal $1 $2 } + : type NAME { newLocal $1 $2 } type :: { CmmType } - : 'bits8' { b8 } - | typenot8 { $1 } + : 'bits8' { b8 } + | typenot8 { $1 } typenot8 :: { CmmType } - : 'bits16' { b16 } - | 'bits32' { b32 } - | 'bits64' { b64 } - | 'float32' { f32 } - | 'float64' { f64 } - | 'gcptr' { gcWord } + : 'bits16' { b16 } + | 'bits32' { b32 } + | 'bits64' { b64 } + | 'float32' { f32 } + | 'float64' { f64 } + | 'gcptr' { gcWord } { section :: String -> Section -section "text" = Text -section "data" = Data -section "rodata" = ReadOnlyData +section "text" = Text +section "data" = Data +section "rodata" = ReadOnlyData section "relrodata" = RelocatableReadOnlyData -section "bss" = UninitialisedData -section s = OtherSection s +section "bss" = UninitialisedData +section s = OtherSection s mkString :: String -> CmmStatic mkString s = CmmString (map (fromIntegral.ord) s) @@ -638,10 +639,10 @@ getLit (CmmMachOp (MO_S_Neg _) [CmmLit (CmmInt i r)]) = CmmInt (negate i) r getLit _ = panic "invalid literal" -- TODO messy failure nameToMachOp :: FastString -> P (Width -> MachOp) -nameToMachOp name = +nameToMachOp name = case lookupUFM machOps name of - Nothing -> fail ("unknown primitive " ++ unpackFS name) - Just m -> return m + Nothing -> fail ("unknown primitive " ++ unpackFS name) + Just m -> return m exprOp :: FastString -> [ExtFCode CmmExpr] -> P (ExtFCode CmmExpr) exprOp name args_code = do @@ -649,10 +650,10 @@ exprOp name args_code = do case lookupUFM (exprMacros dflags) name of Just f -> return $ do args <- sequence args_code - return (f args) + return (f args) Nothing -> do - mo <- nameToMachOp name - return $ mkMachOp mo args_code + mo <- nameToMachOp name + return $ mkMachOp mo args_code exprMacros :: DynFlags -> UniqFM ([CmmExpr] -> CmmExpr) exprMacros dflags = listToUFM [ @@ -670,35 +671,35 @@ exprMacros dflags = listToUFM [ -- 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 ), + 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 ), ( "and", MO_And ), - ( "or", MO_Or ), - ( "xor", MO_Xor ), - ( "com", MO_Not ), - ( "shl", MO_Shl ), - ( "shrl", MO_U_Shr ), - ( "shra", MO_S_Shr ), + ( "or", MO_Or ), + ( "xor", MO_Xor ), + ( "com", MO_Not ), + ( "shl", MO_Shl ), + ( "shrl", MO_U_Shr ), + ( "shra", MO_S_Shr ), ( "fadd", MO_F_Add ), ( "fsub", MO_F_Sub ), @@ -714,30 +715,30 @@ machOps = listToUFM $ ( "flt", MO_F_Lt ), ( "lobits8", flip MO_UU_Conv W8 ), - ( "lobits16", flip MO_UU_Conv W16 ), - ( "lobits32", flip MO_UU_Conv W32 ), - ( "lobits64", flip MO_UU_Conv W64 ), - - ( "zx16", flip MO_UU_Conv W16 ), - ( "zx32", flip MO_UU_Conv W32 ), - ( "zx64", flip MO_UU_Conv W64 ), - - ( "sx16", flip MO_SS_Conv W16 ), - ( "sx32", flip MO_SS_Conv W32 ), - ( "sx64", flip MO_SS_Conv W64 ), - - ( "f2f32", flip MO_FF_Conv W32 ), -- TODO; rounding mode - ( "f2f64", flip MO_FF_Conv W64 ), -- TODO; rounding mode - ( "f2i8", flip MO_FS_Conv W8 ), - ( "f2i16", flip MO_FS_Conv W16 ), - ( "f2i32", flip MO_FS_Conv W32 ), - ( "f2i64", flip MO_FS_Conv W64 ), - ( "i2f32", flip MO_SF_Conv W32 ), - ( "i2f64", flip MO_SF_Conv W64 ) - ] + ( "lobits16", flip MO_UU_Conv W16 ), + ( "lobits32", flip MO_UU_Conv W32 ), + ( "lobits64", flip MO_UU_Conv W64 ), + + ( "zx16", flip MO_UU_Conv W16 ), + ( "zx32", flip MO_UU_Conv W32 ), + ( "zx64", flip MO_UU_Conv W64 ), + + ( "sx16", flip MO_SS_Conv W16 ), + ( "sx32", flip MO_SS_Conv W32 ), + ( "sx64", flip MO_SS_Conv W64 ), + + ( "f2f32", flip MO_FF_Conv W32 ), -- TODO; rounding mode + ( "f2f64", flip MO_FF_Conv W64 ), -- TODO; rounding mode + ( "f2i8", flip MO_FS_Conv W8 ), + ( "f2i16", flip MO_FS_Conv W16 ), + ( "f2i32", flip MO_FS_Conv W32 ), + ( "f2i64", flip MO_FS_Conv W64 ), + ( "i2f32", flip MO_SF_Conv W32 ), + ( "i2f64", flip MO_SF_Conv W64 ) + ] callishMachOps = listToUFM $ - map (\(x, y) -> (mkFastString x, y)) [ + map (\(x, y) -> (mkFastString x, y)) [ ( "write_barrier", MO_WriteBarrier ), ( "memcpy", MO_Memcpy ), ( "memset", MO_Memset ), @@ -762,15 +763,15 @@ inferCmmHint (CmmLit (CmmLabel _)) = AddrHint inferCmmHint (CmmReg (CmmGlobal g)) | isPtrGlobalReg g = AddrHint inferCmmHint _ = NoHint -isPtrGlobalReg Sp = True -isPtrGlobalReg SpLim = True -isPtrGlobalReg Hp = True -isPtrGlobalReg HpLim = True +isPtrGlobalReg Sp = True +isPtrGlobalReg SpLim = True +isPtrGlobalReg Hp = True +isPtrGlobalReg HpLim = True isPtrGlobalReg CCCS = True isPtrGlobalReg CurrentTSO = True isPtrGlobalReg CurrentNursery = True isPtrGlobalReg (VanillaReg _ VGcPtr) = True -isPtrGlobalReg _ = False +isPtrGlobalReg _ = False happyError :: P a happyError = srcParseFail @@ -783,54 +784,54 @@ 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) + 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 "CCS_ALLOC", \[words,ccs] -> profAlloc words ccs ), + ( fsLit "CLOSE_NURSERY", \[] -> emitCloseNursery ), ( fsLit "ENTER_CCS_THUNK", \[e] -> enterCostCentreThunk e ), - ( fsLit "HP_CHK_GEN", \[words,liveness,reentry] -> + ( 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 "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] -> + ( 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 "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_NPP", \[a,b,c] -> emitRetUT [(NonPtrArg,a),(PtrArg,b),(PtrArg,c)]), - ( fsLit "RET_NNP", \[a,b,c] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(PtrArg,c)]), + ( 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_NPP", \[a,b,c] -> emitRetUT [(NonPtrArg,a),(PtrArg,b),(PtrArg,c)]), + ( fsLit "RET_NNP", \[a,b,c] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(PtrArg,c)]), ( fsLit "RET_NNN", \[a,b,c] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c)]), ( fsLit "RET_NNNN", \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c),(NonPtrArg,d)]), - ( 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)]) + ( 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)]) ] -profilingInfo dflags desc_str ty_str +profilingInfo dflags desc_str ty_str = if not (dopt Opt_SccProfilingOn dflags) then NoProfilingInfo else ProfilingInfo (stringToWord8s desc_str) @@ -843,11 +844,11 @@ staticClosure pkg cl_label info payload code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits foreignCall - :: String - -> [ExtFCode HintedCmmFormal] - -> ExtFCode CmmExpr - -> [ExtFCode HintedCmmActual] - -> Maybe [GlobalReg] + :: String + -> [ExtFCode HintedCmmFormal] + -> ExtFCode CmmExpr + -> [ExtFCode HintedCmmActual] + -> Maybe [GlobalReg] -> CmmSafety -> CmmReturnInfo -> P ExtCode @@ -857,76 +858,77 @@ foreignCall conv_string results_code expr_code args_code vols safety ret "stdcall" -> return StdCallConv "C--" -> return CmmCallConv _ -> fail ("unknown calling convention: " ++ conv_string) - return $ do - results <- sequence results_code - expr <- expr_code - args <- sequence args_code + return $ do + dflags <- getDynFlags + let platform = targetPlatform dflags + results <- sequence results_code + expr <- expr_code + args <- sequence args_code case convention of -- Temporary hack so at least some functions are CmmSafe CmmCallConv -> code (stmtC (CmmCall (CmmCallee expr convention) results args ret)) _ -> - let expr' = adjCallTarget convention expr args in + let expr' = adjCallTarget platform convention expr args in case safety of - CmmUnsafe -> - code (emitForeignCall' PlayRisky results + CmmUnsafe -> + code (emitForeignCall' PlayRisky results (CmmCallee expr' convention) args vols NoC_SRT ret) CmmSafe srt -> - code (emitForeignCall' PlaySafe results + code (emitForeignCall' PlaySafe results (CmmCallee expr' convention) args vols NoC_SRT ret) where CmmInterruptible -> - code (emitForeignCall' PlayInterruptible results + code (emitForeignCall' PlayInterruptible results (CmmCallee expr' convention) args vols NoC_SRT ret) -adjCallTarget :: CCallConv -> CmmExpr -> [CmmHinted CmmExpr] -> CmmExpr -#ifdef mingw32_TARGET_OS +adjCallTarget :: Platform -> CCallConv -> CmmExpr -> [CmmHinted CmmExpr] + -> CmmExpr -- On Windows, we have to add the '@N' suffix to the label when making -- a call with the stdcall calling convention. -adjCallTarget StdCallConv (CmmLit (CmmLabel lbl)) args +adjCallTarget (Platform { platformOS = OSMinGW32 }) StdCallConv (CmmLit (CmmLabel lbl)) args = CmmLit (CmmLabel (addLabelSize lbl (sum (map size args)))) where size (CmmHinted e _) = max wORD_SIZE (widthInBytes (typeWidth (cmmExprType e))) -- c.f. CgForeignCall.emitForeignCall -#endif -adjCallTarget _ expr _ +adjCallTarget _ _ expr _ = expr primCall - :: [ExtFCode HintedCmmFormal] - -> FastString - -> [ExtFCode HintedCmmActual] - -> Maybe [GlobalReg] + :: [ExtFCode HintedCmmFormal] + -> FastString + -> [ExtFCode HintedCmmActual] + -> Maybe [GlobalReg] -> CmmSafety -> P ExtCode primCall results_code name args_code vols safety = case lookupUFM callishMachOps name of - Nothing -> fail ("unknown primitive " ++ unpackFS name) - Just p -> return $ do - results <- sequence results_code - args <- sequence args_code - case safety of - CmmUnsafe -> - code (emitForeignCall' PlayRisky results - (CmmPrim p Nothing) args vols NoC_SRT CmmMayReturn) - CmmSafe srt -> - code (emitForeignCall' PlaySafe results - (CmmPrim p Nothing) args vols NoC_SRT CmmMayReturn) where - CmmInterruptible -> - code (emitForeignCall' PlayInterruptible results - (CmmPrim p Nothing) args vols NoC_SRT CmmMayReturn) + Nothing -> fail ("unknown primitive " ++ unpackFS name) + Just p -> return $ do + results <- sequence results_code + args <- sequence args_code + case safety of + CmmUnsafe -> + code (emitForeignCall' PlayRisky results + (CmmPrim p Nothing) args vols NoC_SRT CmmMayReturn) + CmmSafe srt -> + code (emitForeignCall' PlaySafe results + (CmmPrim p Nothing) args vols NoC_SRT CmmMayReturn) where + CmmInterruptible -> + code (emitForeignCall' PlayInterruptible results + (CmmPrim p Nothing) args vols NoC_SRT CmmMayReturn) doStore :: CmmType -> 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. + -- 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 val_width = typeWidth (cmmExprType val) rep_width = typeWidth rep - let coerce_val - | val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val] - | otherwise = val + let coerce_val + | val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val] + | otherwise = val stmtEC (CmmStore addr coerce_val) -- Return an unboxed tuple. @@ -984,10 +986,10 @@ 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. + -- 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 @@ -1010,35 +1012,35 @@ emitCond (e1 `BoolAnd` e2) then_id = do doSwitch :: Maybe (Int,Int) -> ExtFCode CmmExpr -> [([Int],Either BlockId 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 + = 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],Either BlockId ExtCode) -> ExtFCode [(Int,BlockId)] - emitArm (ints,Left blockid) = return [ (i,blockid) | i <- ints ] - emitArm (ints,Right code) = do - blockid <- forkLabelledCodeEC code - return [ (i,blockid) | i <- ints ] + emitArm :: ([Int],Either BlockId ExtCode) -> ExtFCode [(Int,BlockId)] + emitArm (ints,Left blockid) = return [ (i,blockid) | i <- ints ] + emitArm (ints,Right code) = do + blockid <- forkLabelledCodeEC code + return [ (i,blockid) | i <- ints ] -- ----------------------------------------------------------------------------- -- Putting it all together @@ -1047,7 +1049,7 @@ doSwitch mb_range scrut arms deflt -- knows about here. initEnv :: DynFlags -> Env initEnv dflags = listToUFM [ - ( fsLit "SIZEOF_StgHeader", + ( fsLit "SIZEOF_StgHeader", VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize dflags * wORD_SIZE)) wordWidth) )), ( fsLit "SIZEOF_StgInfoTable", VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB dflags)) wordWidth) )) @@ -1058,10 +1060,10 @@ parseCmmFile dflags filename = do showPass dflags "ParseCmm" buf <- hGetStringBuffer filename let - init_loc = mkRealSrcLoc (mkFastString filename) 1 1 - init_state = (mkPState dflags buf init_loc) { lex_state = [0] } - -- reset the lex_state: the Lexer monad leaves some stuff - -- in there we don't want. + init_loc = mkRealSrcLoc (mkFastString filename) 1 1 + init_state = (mkPState dflags buf init_loc) { 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 let msg = mkPlainErrMsg dflags span err @@ -1076,5 +1078,5 @@ parseCmmFile dflags filename = do dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (ppr cmm) return (ms, Just cmm) where - no_module = panic "parseCmmFile: no module" + no_module = panic "parseCmmFile: no module" } diff --git a/compiler/codeGen/CodeGen/Platform.hs b/compiler/codeGen/CodeGen/Platform.hs index 78fba978ec..ca3bafb8de 100644 --- a/compiler/codeGen/CodeGen/Platform.hs +++ b/compiler/codeGen/CodeGen/Platform.hs @@ -1,8 +1,12 @@ -module CodeGen.Platform (callerSaves, activeStgRegs, haveRegBase) where +module CodeGen.Platform + (callerSaves, activeStgRegs, haveRegBase, globalRegMaybe, freeReg) + where import CmmExpr +import FastBool import Platform +import Reg import qualified CodeGen.Platform.ARM as ARM import qualified CodeGen.Platform.PPC as PPC @@ -71,3 +75,37 @@ haveRegBase platform | otherwise -> NoRegs.haveRegBase +globalRegMaybe :: Platform -> GlobalReg -> Maybe RealReg +globalRegMaybe platform + | platformUnregisterised platform = NoRegs.globalRegMaybe + | otherwise + = case platformArch platform of + ArchX86 -> X86.globalRegMaybe + ArchX86_64 -> X86_64.globalRegMaybe + ArchSPARC -> SPARC.globalRegMaybe + ArchARM {} -> ARM.globalRegMaybe + arch + | arch `elem` [ArchPPC, ArchPPC_64] -> + case platformOS platform of + OSDarwin -> PPC_Darwin.globalRegMaybe + _ -> PPC.globalRegMaybe + + | otherwise -> NoRegs.globalRegMaybe + +freeReg :: Platform -> RegNo -> FastBool +freeReg platform + | platformUnregisterised platform = NoRegs.freeReg + | otherwise + = case platformArch platform of + ArchX86 -> X86.freeReg + ArchX86_64 -> X86_64.freeReg + ArchSPARC -> SPARC.freeReg + ArchARM {} -> ARM.freeReg + arch + | arch `elem` [ArchPPC, ArchPPC_64] -> + case platformOS platform of + OSDarwin -> PPC_Darwin.freeReg + _ -> PPC.freeReg + + | otherwise -> NoRegs.freeReg + diff --git a/compiler/codeGen/CodeGen/Platform/ARM.hs b/compiler/codeGen/CodeGen/Platform/ARM.hs index cad3eb7f50..727a43561f 100644 --- a/compiler/codeGen/CodeGen/Platform/ARM.hs +++ b/compiler/codeGen/CodeGen/Platform/ARM.hs @@ -1,8 +1,6 @@ module CodeGen.Platform.ARM where -import CmmExpr - #define MACHREGS_NO_REGS 0 #define MACHREGS_arm 1 #include "../../../../includes/CodeGen.Platform.hs" diff --git a/compiler/codeGen/CodeGen/Platform/NoRegs.hs b/compiler/codeGen/CodeGen/Platform/NoRegs.hs index 6d7c3342d0..c4c63b7572 100644 --- a/compiler/codeGen/CodeGen/Platform/NoRegs.hs +++ b/compiler/codeGen/CodeGen/Platform/NoRegs.hs @@ -1,8 +1,6 @@ module CodeGen.Platform.NoRegs where -import CmmExpr - #define MACHREGS_NO_REGS 1 #include "../../../../includes/CodeGen.Platform.hs" diff --git a/compiler/codeGen/CodeGen/Platform/PPC.hs b/compiler/codeGen/CodeGen/Platform/PPC.hs index 19d0609ae2..bcbdfe244b 100644 --- a/compiler/codeGen/CodeGen/Platform/PPC.hs +++ b/compiler/codeGen/CodeGen/Platform/PPC.hs @@ -1,8 +1,6 @@ module CodeGen.Platform.PPC where -import CmmExpr - #define MACHREGS_NO_REGS 0 #define MACHREGS_powerpc 1 #include "../../../../includes/CodeGen.Platform.hs" diff --git a/compiler/codeGen/CodeGen/Platform/PPC_Darwin.hs b/compiler/codeGen/CodeGen/Platform/PPC_Darwin.hs index a53ee06cc2..42bf22f26c 100644 --- a/compiler/codeGen/CodeGen/Platform/PPC_Darwin.hs +++ b/compiler/codeGen/CodeGen/Platform/PPC_Darwin.hs @@ -1,8 +1,6 @@ module CodeGen.Platform.PPC_Darwin where -import CmmExpr - #define MACHREGS_NO_REGS 0 #define MACHREGS_powerpc 1 #define MACHREGS_darwin 1 diff --git a/compiler/codeGen/CodeGen/Platform/SPARC.hs b/compiler/codeGen/CodeGen/Platform/SPARC.hs index 391d6c8086..b49af14409 100644 --- a/compiler/codeGen/CodeGen/Platform/SPARC.hs +++ b/compiler/codeGen/CodeGen/Platform/SPARC.hs @@ -1,8 +1,6 @@ module CodeGen.Platform.SPARC where -import CmmExpr - #define MACHREGS_NO_REGS 0 #define MACHREGS_sparc 1 #include "../../../../includes/CodeGen.Platform.hs" diff --git a/compiler/codeGen/CodeGen/Platform/X86.hs b/compiler/codeGen/CodeGen/Platform/X86.hs index c5ea94f68c..6dd74df130 100644 --- a/compiler/codeGen/CodeGen/Platform/X86.hs +++ b/compiler/codeGen/CodeGen/Platform/X86.hs @@ -1,8 +1,6 @@ module CodeGen.Platform.X86 where -import CmmExpr - #define MACHREGS_NO_REGS 0 #define MACHREGS_i386 1 #include "../../../../includes/CodeGen.Platform.hs" diff --git a/compiler/codeGen/CodeGen/Platform/X86_64.hs b/compiler/codeGen/CodeGen/Platform/X86_64.hs index c5aa0808b6..190d642ea6 100644 --- a/compiler/codeGen/CodeGen/Platform/X86_64.hs +++ b/compiler/codeGen/CodeGen/Platform/X86_64.hs @@ -1,8 +1,6 @@ module CodeGen.Platform.X86_64 where -import CmmExpr - #define MACHREGS_NO_REGS 0 #define MACHREGS_x86_64 1 #include "../../../../includes/CodeGen.Platform.hs" diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs index 7680bab292..0bd199ff18 100644 --- a/compiler/coreSyn/CorePrep.lhs +++ b/compiler/coreSyn/CorePrep.lhs @@ -46,6 +46,7 @@ import DynFlags import Util import Pair import Outputable +import Platform import FastString import Config import Data.Bits @@ -156,7 +157,7 @@ corePrepPgm :: DynFlags -> HscEnv -> CoreProgram -> [TyCon] -> IO CoreProgram corePrepPgm dflags hsc_env binds data_tycons = do showPass dflags "CorePrep" us <- mkSplitUniqSupply 's' - initialCorePrepEnv <- mkInitialCorePrepEnv hsc_env + initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env let implicit_binds = mkDataConWorkers data_tycons -- NB: we must feed mkImplicitBinds through corePrep too @@ -174,7 +175,7 @@ corePrepExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr corePrepExpr dflags hsc_env expr = do showPass dflags "CorePrep" us <- mkSplitUniqSupply 's' - initialCorePrepEnv <- mkInitialCorePrepEnv hsc_env + initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env let new_expr = initUs_ us (cpeBodyNF initialCorePrepEnv expr) dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" (ppr new_expr) return new_expr @@ -401,6 +402,8 @@ cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs ; return (floats3, bndr', rhs') } where + platform = targetPlatform (cpe_dynFlags env) + arity = idArity bndr -- We must match this arity --------------------- @@ -422,7 +425,7 @@ cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs = return (floats, rhs) -- So the top-level binding is marked NoCafRefs - | Just (floats', rhs') <- canFloatFromNoCaf floats rhs + | Just (floats', rhs') <- canFloatFromNoCaf platform floats rhs = return (floats', rhs') | otherwise @@ -1069,9 +1072,9 @@ dropDeadCodeAlts alts = (alts', unionVarSets fvss) where !(e', fvs) = dropDeadCode e ------------------------------------------- -canFloatFromNoCaf :: Floats -> CpeRhs -> Maybe (Floats, CpeRhs) +canFloatFromNoCaf :: Platform -> Floats -> CpeRhs -> Maybe (Floats, CpeRhs) -- Note [CafInfo and floating] -canFloatFromNoCaf (Floats ok_to_spec fs) rhs +canFloatFromNoCaf platform (Floats ok_to_spec fs) rhs | OkToSpec <- ok_to_spec -- Worth trying , Just (subst, fs') <- go (emptySubst, nilOL) (fromOL fs) = Just (Floats OkToSpec fs', subst_expr subst rhs) @@ -1114,7 +1117,7 @@ canFloatFromNoCaf (Floats ok_to_spec fs) rhs -- We can only float to top level from a NoCaf thing if -- the new binding is static. However it can't mention -- any non-static things or it would *already* be Caffy - rhs_ok = rhsIsStatic (\_ -> False) + rhs_ok = rhsIsStatic platform (\_ -> False) wantFloatNested :: RecFlag -> Bool -> Floats -> CpeRhs -> Bool wantFloatNested is_rec strict_or_unlifted floats rhs @@ -1148,31 +1151,38 @@ allLazyNested is_rec (Floats IfUnboxedOk _) = isNonRec is_rec -- The environment -- --------------------------------------------------------------------------- -data CorePrepEnv = CPE (IdEnv Id) -- Clone local Ids - Id -- mkIntegerId +data CorePrepEnv = CPE { + cpe_dynFlags :: DynFlags, + cpe_env :: (IdEnv Id), -- Clone local Ids + cpe_mkIntegerId :: Id + } -mkInitialCorePrepEnv :: HscEnv -> IO CorePrepEnv -mkInitialCorePrepEnv hsc_env +mkInitialCorePrepEnv :: DynFlags -> HscEnv -> IO CorePrepEnv +mkInitialCorePrepEnv dflags hsc_env = do mkIntegerId <- liftM tyThingId $ initTcForLookup hsc_env (tcLookupGlobal mkIntegerName) - return $ CPE emptyVarEnv mkIntegerId + return $ CPE { + cpe_dynFlags = dflags, + cpe_env = emptyVarEnv, + cpe_mkIntegerId = mkIntegerId + } extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv -extendCorePrepEnv (CPE env mkIntegerId) id id' - = CPE (extendVarEnv env id id') mkIntegerId +extendCorePrepEnv cpe id id' + = cpe { cpe_env = extendVarEnv (cpe_env cpe) id id' } extendCorePrepEnvList :: CorePrepEnv -> [(Id,Id)] -> CorePrepEnv -extendCorePrepEnvList (CPE env mkIntegerId) prs - = CPE (extendVarEnvList env prs) mkIntegerId +extendCorePrepEnvList cpe prs + = cpe { cpe_env = extendVarEnvList (cpe_env cpe) prs } lookupCorePrepEnv :: CorePrepEnv -> Id -> Id -lookupCorePrepEnv (CPE env _) id - = case lookupVarEnv env id of +lookupCorePrepEnv cpe id + = case lookupVarEnv (cpe_env cpe) id of Nothing -> id Just id' -> id' getMkIntegerId :: CorePrepEnv -> Id -getMkIntegerId (CPE _ mkIntegerId) = mkIntegerId +getMkIntegerId = cpe_mkIntegerId ------------------------------------------------------------------------------ -- Cloning binders diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index 12a3fb3491..f15c648694 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -66,6 +66,7 @@ import Outputable import TysPrim import FastString import Maybes +import Platform import Util import Pair import Data.Word @@ -1733,7 +1734,7 @@ and 'execute' it rather than allocating it statically. -- | This function is called only on *top-level* right-hand sides. -- Returns @True@ if the RHS can be allocated statically in the output, -- with no thunks involved at all. -rhsIsStatic :: (Name -> Bool) -> CoreExpr -> Bool +rhsIsStatic :: Platform -> (Name -> Bool) -> CoreExpr -> Bool -- It's called (i) in TidyPgm.hasCafRefs to decide if the rhs is, or -- refers to, CAFs; (ii) in CoreToStg to decide whether to put an -- update flag on it and (iii) in DsExpr to decide how to expand @@ -1788,7 +1789,7 @@ rhsIsStatic :: (Name -> Bool) -> CoreExpr -> Bool -- -- c) don't look through unfolding of f in (f x). -rhsIsStatic _is_dynamic_name rhs = is_static False rhs +rhsIsStatic platform is_dynamic_name rhs = is_static False rhs where is_static :: Bool -- True <=> in a constructor argument; must be atomic -> CoreExpr -> Bool @@ -1813,9 +1814,8 @@ rhsIsStatic _is_dynamic_name rhs = is_static False rhs is_static in_arg other_expr = go other_expr 0 where go (Var f) n_val_args -#if mingw32_TARGET_OS - | not (_is_dynamic_name (idName f)) -#endif + | (platformOS platform /= OSMinGW32) || + not (is_dynamic_name (idName f)) = saturated_data_con f n_val_args || (in_arg && n_val_args == 0) -- A naked un-applied variable is *not* deemed a static RHS diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 12ed631f0f..e02e9d9869 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -509,7 +509,6 @@ Library PPC.CodeGen SPARC.Base SPARC.Regs - SPARC.RegPlate SPARC.Imm SPARC.AddrMode SPARC.Cond diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index 06096c3579..7a5ca901bc 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -51,6 +51,7 @@ import qualified Maybes import UniqSet import FastString import Config +import Platform import SysTools import PrelNames @@ -302,12 +303,13 @@ reallyInitDynLinker dflags = ; classified_ld_inputs <- mapM (classifyLdInput dflags) cmdline_ld_inputs -- (e) Link any MacOS frameworks - ; let framework_paths - | isDarwinTarget = frameworkPaths dflags - | otherwise = [] - ; let frameworks - | isDarwinTarget = cmdlineFrameworks dflags - | otherwise = [] + ; let platform = targetPlatform dflags + ; let framework_paths = case platformOS platform of + OSDarwin -> frameworkPaths dflags + _ -> [] + ; let frameworks = case platformOS platform of + OSDarwin -> cmdlineFrameworks dflags + _ -> [] -- Finally do (c),(d),(e) ; let cmdline_lib_specs = [ l | Just l <- classified_ld_inputs ] ++ libspecs @@ -353,12 +355,13 @@ users? classifyLdInput :: DynFlags -> FilePath -> IO (Maybe LibrarySpec) classifyLdInput dflags f - | isObjectFilename f = return (Just (Object f)) - | isDynLibFilename f = return (Just (DLLPath f)) + | isObjectFilename platform f = return (Just (Object f)) + | isDynLibFilename platform f = return (Just (DLLPath f)) | otherwise = do log_action dflags dflags SevInfo noSrcSpan defaultUserStyle (text ("Warning: ignoring unrecognised input `" ++ f ++ "'")) return Nothing + where platform = targetPlatform dflags preloadLib :: DynFlags -> [String] -> [String] -> LibrarySpec -> IO () preloadLib dflags lib_paths framework_paths lib_spec @@ -375,7 +378,7 @@ preloadLib dflags lib_paths framework_paths lib_spec else "not found") DLL dll_unadorned - -> do maybe_errstr <- loadDLL (mkSOName dll_unadorned) + -> do maybe_errstr <- loadDLL (mkSOName platform dll_unadorned) case maybe_errstr of Nothing -> maybePutStrLn dflags "done" Just mm -> preloadFailed mm lib_paths lib_spec @@ -386,15 +389,18 @@ preloadLib dflags lib_paths framework_paths lib_spec Nothing -> maybePutStrLn dflags "done" Just mm -> preloadFailed mm lib_paths lib_spec - Framework framework - | isDarwinTarget - -> do maybe_errstr <- loadFramework framework_paths framework + Framework framework -> + case platformOS (targetPlatform dflags) of + OSDarwin -> + do maybe_errstr <- loadFramework framework_paths framework case maybe_errstr of Nothing -> maybePutStrLn dflags "done" Just mm -> preloadFailed mm framework_paths lib_spec - | otherwise -> panic "preloadLib Framework" + _ -> panic "preloadLib Framework" where + platform = targetPlatform dflags + preloadFailed :: String -> [String] -> LibrarySpec -> IO () preloadFailed sys_errmsg paths spec = do maybePutStr dflags "failed.\n" @@ -968,7 +974,7 @@ data LibrarySpec -- just to get the DLL handle into the list. partOfGHCi :: [PackageName] partOfGHCi - | isWindowsTarget || isDarwinTarget = [] + | isWindowsHost || isDarwinHost = [] | otherwise = map PackageName ["base", "template-haskell", "editline"] @@ -1033,7 +1039,8 @@ linkPackages' dflags new_pks pls = do linkPackage :: DynFlags -> PackageConfig -> IO () linkPackage dflags pkg = do - let dirs = Packages.libraryDirs pkg + let platform = targetPlatform dflags + dirs = Packages.libraryDirs pkg let hs_libs = Packages.hsLibraries pkg -- The FFI GHCi import lib isn't needed as @@ -1070,8 +1077,8 @@ linkPackage dflags pkg -- See comments with partOfGHCi when (packageName pkg `notElem` partOfGHCi) $ do - loadFrameworks pkg - mapM_ load_dyn (known_dlls ++ map mkSOName dlls) + loadFrameworks platform pkg + mapM_ load_dyn (known_dlls ++ map (mkSOName platform) dlls) -- After loading all the DLLs, we can load the static objects. -- Ordering isn't important here, because we do one final link @@ -1096,10 +1103,11 @@ load_dyn dll = do r <- loadDLL dll Just err -> ghcError (CmdLineError ("can't load .so/.DLL for: " ++ dll ++ " (" ++ err ++ ")" )) -loadFrameworks :: InstalledPackageInfo_ ModuleName -> IO () -loadFrameworks pkg - | isDarwinTarget = mapM_ load frameworks - | otherwise = return () +loadFrameworks :: Platform -> InstalledPackageInfo_ ModuleName -> IO () +loadFrameworks platform pkg + = case platformOS platform of + OSDarwin -> mapM_ load frameworks + _ -> return () where fw_dirs = Packages.frameworkDirs pkg frameworks = Packages.frameworks pkg @@ -1142,9 +1150,9 @@ locateLib dflags is_hs dirs lib mk_arch_path dir = dir </> ("lib" ++ lib <.> "a") hs_dyn_lib_name = lib ++ "-ghc" ++ cProjectVersion - mk_hs_dyn_lib_path dir = dir </> mkSOName hs_dyn_lib_name + mk_hs_dyn_lib_path dir = dir </> mkSOName platform hs_dyn_lib_name - so_name = mkSOName lib + so_name = mkSOName platform lib mk_dyn_lib_path dir = dir </> so_name findObject = liftM (fmap Object) $ findFile mk_obj_path dirs @@ -1160,6 +1168,8 @@ locateLib dflags is_hs dirs lib Just x -> return x Nothing -> g + platform = targetPlatform dflags + searchForLibUsingGcc :: DynFlags -> String -> [FilePath] -> IO (Maybe FilePath) searchForLibUsingGcc dflags so dirs = do str <- askCc dflags (map (FileOption "-L") dirs @@ -1174,11 +1184,12 @@ searchForLibUsingGcc dflags so dirs = do -- ---------------------------------------------------------------------------- -- Loading a dyanmic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32) -mkSOName :: FilePath -> FilePath -mkSOName root - | isDarwinTarget = ("lib" ++ root) <.> "dylib" - | isWindowsTarget = root <.> "dll" - | otherwise = ("lib" ++ root) <.> "so" +mkSOName :: Platform -> FilePath -> FilePath +mkSOName platform root + = case platformOS platform of + OSDarwin -> ("lib" ++ root) <.> "dylib" + OSMinGW32 -> root <.> "dll" + _ -> ("lib" ++ root) <.> "so" -- Darwin / MacOS X only: load a framework -- a framework is a dynamic library packaged inside a directory of the same diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs index 1c715989a8..cf78b3730a 100644 --- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs +++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs @@ -15,6 +15,7 @@ import LlvmCodeGen.Regs import CLabel import OldCmm +import Platform import FastString import Outputable @@ -37,41 +38,29 @@ pprLlvmHeader = -- | LLVM module layout description for the host target moduleLayout :: SDoc -moduleLayout = -#if i386_TARGET_ARCH - -#if darwin_TARGET_OS - text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:32:64-f32:32:32-f64:32:64-v64:64:64-v128:128:128-a0:0:64-f80:128:128-n8:16:32\"" - $+$ text "target triple = \"i386-apple-darwin9.8\"" -#elif mingw32_TARGET_OS - text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-f80:128:128-v64:64:64-v128:128:128-a0:0:64-f80:32:32-n8:16:32\"" - $+$ text "target triple = \"i686-pc-win32\"" -#else /* Linux */ - text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:32:64-f32:32:32-f64:32:64-v64:64:64-v128:128:128-a0:0:64-f80:32:32-n8:16:32\"" - $+$ text "target triple = \"i386-pc-linux-gnu\"" -#endif - -#elif x86_64_TARGET_ARCH - -#if darwin_TARGET_OS - text "target datalayout = \"e-p:64:64:64-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:128:128-a0:0:64-s0:64:64-f80:128:128-n8:16:32:64\"" - $+$ text "target triple = \"x86_64-apple-darwin10.0.0\"" -#else /* Linux */ - text "target datalayout = \"e-p:64:64:64-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:128:128-a0:0:64-s0:64:64-f80:128:128-n8:16:32:64\"" - $+$ text "target triple = \"x86_64-linux-gnu\"" -#endif - -#elif defined (arm_TARGET_ARCH) - -#if linux_TARGET_OS - text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:64:128-a0:0:64-n32\"" - $+$ text "target triple = \"arm-unknown-linux-gnueabi\"" -#endif - -#else - -- FIX: Other targets - empty -#endif +moduleLayout = sdocWithPlatform $ \platform -> + case platform of + Platform { platformArch = ArchX86, platformOS = OSDarwin } -> + text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:32:64-f32:32:32-f64:32:64-v64:64:64-v128:128:128-a0:0:64-f80:128:128-n8:16:32\"" + $+$ text "target triple = \"i386-apple-darwin9.8\"" + Platform { platformArch = ArchX86, platformOS = OSMinGW32 } -> + text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-f80:128:128-v64:64:64-v128:128:128-a0:0:64-f80:32:32-n8:16:32\"" + $+$ text "target triple = \"i686-pc-win32\"" + Platform { platformArch = ArchX86, platformOS = OSLinux } -> + text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:32:64-f32:32:32-f64:32:64-v64:64:64-v128:128:128-a0:0:64-f80:32:32-n8:16:32\"" + $+$ text "target triple = \"i386-pc-linux-gnu\"" + Platform { platformArch = ArchX86_64, platformOS = OSDarwin } -> + text "target datalayout = \"e-p:64:64:64-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:128:128-a0:0:64-s0:64:64-f80:128:128-n8:16:32:64\"" + $+$ text "target triple = \"x86_64-apple-darwin10.0.0\"" + Platform { platformArch = ArchX86_64, platformOS = OSLinux } -> + text "target datalayout = \"e-p:64:64:64-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:128:128-a0:0:64-s0:64:64-f80:128:128-n8:16:32:64\"" + $+$ text "target triple = \"x86_64-linux-gnu\"" + Platform { platformArch = ArchARM {}, platformOS = OSLinux } -> + text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:64:128-a0:0:64-n32\"" + $+$ text "target triple = \"arm-unknown-linux-gnueabi\"" + _ -> + -- FIX: Other targets + empty -- | Pretty print LLVM data code diff --git a/compiler/main/DriverPhases.hs b/compiler/main/DriverPhases.hs index 29dbb58413..a1eac536b6 100644 --- a/compiler/main/DriverPhases.hs +++ b/compiler/main/DriverPhases.hs @@ -36,6 +36,7 @@ module DriverPhases ( #include "HsVersions.h" import Outputable +import Platform import System.FilePath ----------------------------------------------------------------------------- @@ -228,49 +229,47 @@ extcoreish_suffixes = [ "hcr" ] -- Will not be deleted as temp files: haskellish_user_src_suffixes = [ "hs", "lhs", "hs-boot", "lhs-boot" ] -objish_suffixes :: [String] +objish_suffixes :: Platform -> [String] -- Use the appropriate suffix for the system on which -- the GHC-compiled code will run -#if mingw32_TARGET_OS || cygwin32_TARGET_OS -objish_suffixes = [ "o", "O", "obj", "OBJ" ] -#else -objish_suffixes = [ "o" ] -#endif +objish_suffixes platform = case platformOS platform of + OSMinGW32 -> [ "o", "O", "obj", "OBJ" ] + _ -> [ "o" ] -dynlib_suffixes :: [String] -#ifdef mingw32_TARGET_OS -dynlib_suffixes = ["dll", "DLL"] -#elif defined(darwin_TARGET_OS) -dynlib_suffixes = ["dylib"] -#else -dynlib_suffixes = ["so"] -#endif +dynlib_suffixes :: Platform -> [String] +dynlib_suffixes platform = case platformOS platform of + OSMinGW32 -> ["dll", "DLL"] + OSDarwin -> ["dylib"] + _ -> ["so"] isHaskellishSuffix, isHaskellSrcSuffix, isCishSuffix, isExtCoreSuffix, - isObjectSuffix, isHaskellUserSrcSuffix, isDynLibSuffix + isHaskellUserSrcSuffix :: String -> Bool isHaskellishSuffix s = s `elem` haskellish_suffixes isHaskellSrcSuffix s = s `elem` haskellish_src_suffixes isCishSuffix s = s `elem` cish_suffixes isExtCoreSuffix s = s `elem` extcoreish_suffixes -isObjectSuffix s = s `elem` objish_suffixes isHaskellUserSrcSuffix s = s `elem` haskellish_user_src_suffixes -isDynLibSuffix s = s `elem` dynlib_suffixes + +isObjectSuffix, isDynLibSuffix :: Platform -> String -> Bool +isObjectSuffix platform s = s `elem` objish_suffixes platform +isDynLibSuffix platform s = s `elem` dynlib_suffixes platform isSourceSuffix :: String -> Bool isSourceSuffix suff = isHaskellishSuffix suff || isCishSuffix suff isHaskellishFilename, isHaskellSrcFilename, isCishFilename, - isExtCoreFilename, isObjectFilename, isHaskellUserSrcFilename, - isDynLibFilename, isSourceFilename + isExtCoreFilename, isHaskellUserSrcFilename, isSourceFilename :: FilePath -> Bool -- takeExtension return .foo, so we drop 1 to get rid of the . isHaskellishFilename f = isHaskellishSuffix (drop 1 $ takeExtension f) isHaskellSrcFilename f = isHaskellSrcSuffix (drop 1 $ takeExtension f) isCishFilename f = isCishSuffix (drop 1 $ takeExtension f) isExtCoreFilename f = isExtCoreSuffix (drop 1 $ takeExtension f) -isObjectFilename f = isObjectSuffix (drop 1 $ takeExtension f) isHaskellUserSrcFilename f = isHaskellUserSrcSuffix (drop 1 $ takeExtension f) -isDynLibFilename f = isDynLibSuffix (drop 1 $ takeExtension f) isSourceFilename f = isSourceSuffix (drop 1 $ takeExtension f) +isObjectFilename, isDynLibFilename :: Platform -> FilePath -> Bool +isObjectFilename platform f = isObjectSuffix platform (drop 1 $ takeExtension f) +isDynLibFilename platform f = isDynLibSuffix platform (drop 1 $ takeExtension f) + diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 85127e63f6..bea9f14ee6 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -47,6 +47,7 @@ import Module import Packages( isDllName ) import HscTypes import Maybes +import Platform import UniqSupply import ErrUtils (Severity(..)) import Outputable @@ -1048,34 +1049,37 @@ tidyTopBinds hsc_env unfold_env init_occ_env binds $ initTcForLookup hsc_env (tcLookupGlobal mkIntegerName) return $ tidy mkIntegerId init_env binds where + platform = targetPlatform (hsc_dflags hsc_env) + init_env = (init_occ_env, emptyVarEnv) this_pkg = thisPackage (hsc_dflags hsc_env) tidy _ env [] = (env, []) - tidy mkIntegerId env (b:bs) = let (env1, b') = tidyTopBind this_pkg mkIntegerId unfold_env env b + tidy mkIntegerId env (b:bs) = let (env1, b') = tidyTopBind platform this_pkg mkIntegerId unfold_env env b (env2, bs') = tidy mkIntegerId env1 bs in (env2, b':bs') ------------------------ -tidyTopBind :: PackageId +tidyTopBind :: Platform + -> PackageId -> Id -> UnfoldEnv -> TidyEnv -> CoreBind -> (TidyEnv, CoreBind) -tidyTopBind this_pkg mkIntegerId unfold_env (occ_env,subst1) (NonRec bndr rhs) +tidyTopBind platform this_pkg mkIntegerId unfold_env (occ_env,subst1) (NonRec bndr rhs) = (tidy_env2, NonRec bndr' rhs') where Just (name',show_unfold) = lookupVarEnv unfold_env bndr - caf_info = hasCafRefs this_pkg (mkIntegerId, subst1) (idArity bndr) rhs + caf_info = hasCafRefs platform this_pkg (mkIntegerId, subst1) (idArity bndr) rhs (bndr', rhs') = tidyTopPair show_unfold tidy_env2 caf_info name' (bndr, rhs) subst2 = extendVarEnv subst1 bndr bndr' tidy_env2 = (occ_env, subst2) -tidyTopBind this_pkg mkIntegerId unfold_env (occ_env,subst1) (Rec prs) +tidyTopBind platform this_pkg mkIntegerId unfold_env (occ_env,subst1) (Rec prs) = (tidy_env2, Rec prs') where prs' = [ tidyTopPair show_unfold tidy_env2 caf_info name' (id,rhs) @@ -1092,7 +1096,7 @@ tidyTopBind this_pkg mkIntegerId unfold_env (occ_env,subst1) (Rec prs) -- the CafInfo for a recursive group says whether *any* rhs in -- the group may refer indirectly to a CAF (because then, they all do). caf_info - | or [ mayHaveCafRefs (hasCafRefs this_pkg (mkIntegerId, subst1) (idArity bndr) rhs) + | or [ mayHaveCafRefs (hasCafRefs platform this_pkg (mkIntegerId, subst1) (idArity bndr) rhs) | (bndr,rhs) <- prs ] = MayHaveCafRefs | otherwise = NoCafRefs @@ -1229,14 +1233,15 @@ it as a CAF. In these cases however, we would need to use an additional CAF list to keep track of non-collectable CAFs. \begin{code} -hasCafRefs :: PackageId -> (Id, VarEnv Var) -> Arity -> CoreExpr -> CafInfo -hasCafRefs this_pkg p arity expr +hasCafRefs :: Platform -> PackageId -> (Id, VarEnv Var) -> Arity -> CoreExpr + -> CafInfo +hasCafRefs platform this_pkg p arity expr | is_caf || mentions_cafs = MayHaveCafRefs | otherwise = NoCafRefs where mentions_cafs = isFastTrue (cafRefsE p expr) is_dynamic_name = isDllName this_pkg - is_caf = not (arity > 0 || rhsIsStatic is_dynamic_name expr) + is_caf = not (arity > 0 || rhsIsStatic platform is_dynamic_name expr) -- NB. we pass in the arity of the expression, which is expected -- to be calculated by exprArity. This is because exprArity diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index 65fc4e339c..6b1e93f271 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -179,7 +179,7 @@ nativeCodeGen dflags h us cmms ,shortcutJump = PPC.RegInfo.shortcutJump ,pprNatCmmDecl = PPC.Ppr.pprNatCmmDecl ,maxSpillSlots = PPC.Instr.maxSpillSlots - ,allocatableRegs = \_ -> PPC.Regs.allocatableRegs + ,allocatableRegs = PPC.Regs.allocatableRegs ,ncg_x86fp_kludge = id ,ncgExpandTop = id ,ncgMakeFarBranches = makeFarBranches diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs index b6c83eec0a..ce4a54ca9b 100644 --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -25,6 +25,7 @@ where #include "../includes/MachDeps.h" -- NCG stuff: +import CodeGen.Platform import PPC.Instr import PPC.Cond import PPC.Regs @@ -171,13 +172,13 @@ swizzleRegisterRep (Any _ codefn) size = Any size codefn -- | Grab the Reg for a CmmReg -getRegisterReg :: CmmReg -> Reg +getRegisterReg :: Platform -> CmmReg -> Reg -getRegisterReg (CmmLocal (LocalReg u pk)) +getRegisterReg _ (CmmLocal (LocalReg u pk)) = RegVirtual $ mkVirtualReg u (cmmTypeSize pk) -getRegisterReg (CmmGlobal mid) - = case globalRegMaybe mid of +getRegisterReg platform (CmmGlobal mid) + = case globalRegMaybe platform mid of Just reg -> RegReal reg Nothing -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid) -- By this stage, the only MagicIds remaining should be the @@ -368,9 +369,9 @@ getRegister' _ (CmmReg (CmmGlobal PicBaseReg)) reg <- getPicBaseNat archWordSize return (Fixed archWordSize reg nilOL) -getRegister' _ (CmmReg reg) +getRegister' dflags (CmmReg reg) = return (Fixed (cmmTypeSize (cmmRegType reg)) - (getRegisterReg reg) nilOL) + (getRegisterReg (targetPlatform dflags) reg) nilOL) getRegister' dflags tree@(CmmRegOff _ _) = getRegister' dflags (mangleIndexTree tree) @@ -763,12 +764,12 @@ assignMem_IntCode pk addr src = do -- dst is a reg, but src could be anything assignReg_IntCode _ reg src = do + dflags <- getDynFlags + let dst = getRegisterReg (targetPlatform dflags) reg r <- getRegister src return $ case r of Any _ code -> code dst Fixed _ freg fcode -> fcode `snocOL` MR dst freg - where - dst = getRegisterReg reg @@ -841,15 +842,17 @@ genCCall :: CmmCallTarget -- function to call -> NatM InstrBlock genCCall target dest_regs argsAndHints = do dflags <- getDynFlags - case platformOS (targetPlatform dflags) of - OSLinux -> genCCall' GCPLinux target dest_regs argsAndHints - OSDarwin -> genCCall' GCPDarwin target dest_regs argsAndHints + let platform = targetPlatform dflags + case platformOS platform of + OSLinux -> genCCall' platform GCPLinux target dest_regs argsAndHints + OSDarwin -> genCCall' platform GCPDarwin target dest_regs argsAndHints _ -> panic "PPC.CodeGen.genCCall: not defined for this os" data GenCCallPlatform = GCPLinux | GCPDarwin genCCall' - :: GenCCallPlatform + :: Platform + -> GenCCallPlatform -> CmmCallTarget -- function to call -> [HintedCmmFormal] -- where to put the result -> [HintedCmmActual] -- arguments (of mixed type) @@ -893,19 +896,20 @@ genCCall' -} -genCCall' _ (CmmPrim MO_WriteBarrier _) _ _ +genCCall' _ _ (CmmPrim MO_WriteBarrier _) _ _ = return $ unitOL LWSYNC -genCCall' _ (CmmPrim _ (Just stmts)) _ _ +genCCall' _ _ (CmmPrim _ (Just stmts)) _ _ = stmtsToInstrs stmts -genCCall' gcp target dest_regs argsAndHints +genCCall' platform gcp target dest_regs argsAndHints = ASSERT (not $ any (`elem` [II16]) $ map cmmTypeSize argReps) -- we rely on argument promotion in the codeGen do (finalStack,passArgumentsCode,usedRegs) <- passArguments (zip args argReps) - allArgRegs allFPArgRegs + allArgRegs + (allFPArgRegs platform) initialStackOffset (toOL []) [] @@ -1086,7 +1090,7 @@ genCCall' gcp target dest_regs argsAndHints MR r_dest r4] | otherwise -> unitOL (MR r_dest r3) where rep = cmmRegType (CmmLocal dest) - r_dest = getRegisterReg (CmmLocal dest) + r_dest = getRegisterReg platform (CmmLocal dest) _ -> panic "genCCall' moveResult: Bad dest_regs" outOfLineMachOp mop = diff --git a/compiler/nativeGen/PPC/Instr.hs b/compiler/nativeGen/PPC/Instr.hs index 2e25bd5b16..1af08a6076 100644 --- a/compiler/nativeGen/PPC/Instr.hs +++ b/compiler/nativeGen/PPC/Instr.hs @@ -33,6 +33,7 @@ import TargetReg import RegClass import Reg +import CodeGen.Platform import Constants (rESERVED_C_STACK_BYTES) import BlockId import OldCmm @@ -178,7 +179,7 @@ data Instr -- allocation goes, are taken care of by the register allocator. -- ppc_regUsageOfInstr :: Platform -> Instr -> RegUsage -ppc_regUsageOfInstr _ instr +ppc_regUsageOfInstr platform instr = case instr of LD _ reg addr -> usage (regAddr addr, [reg]) LA _ reg addr -> usage (regAddr addr, [reg]) @@ -193,8 +194,8 @@ ppc_regUsageOfInstr _ instr BCCFAR _ _ -> noUsage MTCTR reg -> usage ([reg],[]) BCTR _ _ -> noUsage - BL _ params -> usage (params, callClobberedRegs) - BCTRL params -> usage (params, callClobberedRegs) + BL _ params -> usage (params, callClobberedRegs platform) + BCTRL params -> usage (params, callClobberedRegs platform) ADD reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) ADDC reg1 reg2 reg3-> usage ([reg2,reg3], [reg1]) ADDE reg1 reg2 reg3-> usage ([reg2,reg3], [reg1]) @@ -230,21 +231,21 @@ ppc_regUsageOfInstr _ instr FETCHPC reg -> usage ([], [reg]) _ -> noUsage where - usage (src, dst) = RU (filter interesting src) - (filter interesting dst) + usage (src, dst) = RU (filter (interesting platform) src) + (filter (interesting platform) dst) regAddr (AddrRegReg r1 r2) = [r1, r2] regAddr (AddrRegImm r1 _) = [r1] regRI (RIReg r) = [r] regRI _ = [] -interesting :: Reg -> Bool -interesting (RegVirtual _) = True -interesting (RegReal (RealRegSingle i)) - = isFastTrue (freeReg i) +interesting :: Platform -> Reg -> Bool +interesting _ (RegVirtual _) = True +interesting platform (RegReal (RealRegSingle i)) + = isFastTrue (freeReg platform i) -interesting (RegReal (RealRegPair{})) - = panic "PPC.Instr.interesting: no reg pairs on this arch" +interesting _ (RegReal (RealRegPair{})) + = panic "PPC.Instr.interesting: no reg pairs on this arch" diff --git a/compiler/nativeGen/PPC/Regs.hs b/compiler/nativeGen/PPC/Regs.hs index b86df54b1e..7dccb6040e 100644 --- a/compiler/nativeGen/PPC/Regs.hs +++ b/compiler/nativeGen/PPC/Regs.hs @@ -37,9 +37,6 @@ module PPC.Regs ( fReg, sp, r3, r4, r27, r28, f1, f20, f21, - -- horrow show - freeReg, - globalRegMaybe, allocatableRegs ) @@ -48,7 +45,6 @@ where #include "nativeGen/NCG.h" #include "HsVersions.h" -#include "../includes/stg/HaskellMachRegs.h" import Reg import RegClass @@ -58,10 +54,12 @@ import OldCmm import CLabel ( CLabel ) import Unique +import CodeGen.Platform import Outputable import Constants import FastBool import FastTypes +import Platform import Data.Word ( Word8, Word16, Word32 ) import Data.Int ( Int8, Int16, Int32 ) @@ -223,19 +221,12 @@ allArgRegs = map regSingle [3..10] -- these are the regs which we cannot assume stay alive over a C call. -callClobberedRegs :: [Reg] -#if defined(darwin_TARGET_OS) -callClobberedRegs - = map regSingle (0:[2..12] ++ map fReg [0..13]) - -#elif defined(linux_TARGET_OS) -callClobberedRegs - = map regSingle (0:[2..13] ++ map fReg [0..13]) - -#else -callClobberedRegs - = panic "PPC.Regs.callClobberedRegs: not defined for this architecture" -#endif +callClobberedRegs :: Platform -> [Reg] +callClobberedRegs platform + = case platformOS platform of + OSDarwin -> map regSingle (0:[2..12] ++ map fReg [0..13]) + OSLinux -> map regSingle (0:[2..13] ++ map fReg [0..13]) + _ -> panic "PPC.Regs.callClobberedRegs: not defined for this architecture" allMachRegNos :: [RegNo] @@ -261,17 +252,12 @@ showReg n -- machine specific ------------------------------------------------------------ -allFPArgRegs :: [Reg] -#if defined(darwin_TARGET_OS) -allFPArgRegs = map (regSingle . fReg) [1..13] - -#elif defined(linux_TARGET_OS) -allFPArgRegs = map (regSingle . fReg) [1..8] - -#else -allFPArgRegs = panic "PPC.Regs.allFPArgRegs: not defined for this architecture" - -#endif +allFPArgRegs :: Platform -> [Reg] +allFPArgRegs platform + = case platformOS platform of + OSDarwin -> map (regSingle . fReg) [1..13] + OSLinux -> map (regSingle . fReg) [1..8] + _ -> panic "PPC.Regs.allFPArgRegs: not defined for this architecture" fits16Bits :: Integral a => a -> Bool fits16Bits x = x >= -32768 && x < 32768 @@ -316,288 +302,10 @@ f1 = regSingle $ fReg 1 f20 = regSingle $ fReg 20 f21 = regSingle $ fReg 21 - - --- horror show ----------------------------------------------------------------- -freeReg :: RegNo -> FastBool -globalRegMaybe :: GlobalReg -> Maybe RealReg - - -#if powerpc_TARGET_ARCH -#define r0 0 -#define r1 1 -#define r2 2 -#define r3 3 -#define r4 4 -#define r5 5 -#define r6 6 -#define r7 7 -#define r8 8 -#define r9 9 -#define r10 10 -#define r11 11 -#define r12 12 -#define r13 13 -#define r14 14 -#define r15 15 -#define r16 16 -#define r17 17 -#define r18 18 -#define r19 19 -#define r20 20 -#define r21 21 -#define r22 22 -#define r23 23 -#define r24 24 -#define r25 25 -#define r26 26 -#define r27 27 -#define r28 28 -#define r29 29 -#define r30 30 -#define r31 31 - -#ifdef darwin_TARGET_OS -#define f0 32 -#define f1 33 -#define f2 34 -#define f3 35 -#define f4 36 -#define f5 37 -#define f6 38 -#define f7 39 -#define f8 40 -#define f9 41 -#define f10 42 -#define f11 43 -#define f12 44 -#define f13 45 -#define f14 46 -#define f15 47 -#define f16 48 -#define f17 49 -#define f18 50 -#define f19 51 -#define f20 52 -#define f21 53 -#define f22 54 -#define f23 55 -#define f24 56 -#define f25 57 -#define f26 58 -#define f27 59 -#define f28 60 -#define f29 61 -#define f30 62 -#define f31 63 -#else -#define fr0 32 -#define fr1 33 -#define fr2 34 -#define fr3 35 -#define fr4 36 -#define fr5 37 -#define fr6 38 -#define fr7 39 -#define fr8 40 -#define fr9 41 -#define fr10 42 -#define fr11 43 -#define fr12 44 -#define fr13 45 -#define fr14 46 -#define fr15 47 -#define fr16 48 -#define fr17 49 -#define fr18 50 -#define fr19 51 -#define fr20 52 -#define fr21 53 -#define fr22 54 -#define fr23 55 -#define fr24 56 -#define fr25 57 -#define fr26 58 -#define fr27 59 -#define fr28 60 -#define fr29 61 -#define fr30 62 -#define fr31 63 -#endif - - - -freeReg 0 = fastBool False -- Hack: r0 can't be used in all insns, but it's actually free -freeReg 1 = fastBool False -- The Stack Pointer -#if !darwin_TARGET_OS - -- most non-darwin powerpc OSes use r2 as a TOC pointer or something like that -freeReg 2 = fastBool False -#endif - -#ifdef REG_Base -freeReg REG_Base = fastBool False -#endif -#ifdef REG_R1 -freeReg REG_R1 = fastBool False -#endif -#ifdef REG_R2 -freeReg REG_R2 = fastBool False -#endif -#ifdef REG_R3 -freeReg REG_R3 = fastBool False -#endif -#ifdef REG_R4 -freeReg REG_R4 = fastBool False -#endif -#ifdef REG_R5 -freeReg REG_R5 = fastBool False -#endif -#ifdef REG_R6 -freeReg REG_R6 = fastBool False -#endif -#ifdef REG_R7 -freeReg REG_R7 = fastBool False -#endif -#ifdef REG_R8 -freeReg REG_R8 = fastBool False -#endif -#ifdef REG_R9 -freeReg REG_R9 = fastBool False -#endif -#ifdef REG_R10 -freeReg REG_R10 = fastBool False -#endif -#ifdef REG_F1 -freeReg REG_F1 = fastBool False -#endif -#ifdef REG_F2 -freeReg REG_F2 = fastBool False -#endif -#ifdef REG_F3 -freeReg REG_F3 = fastBool False -#endif -#ifdef REG_F4 -freeReg REG_F4 = fastBool False -#endif -#ifdef REG_D1 -freeReg REG_D1 = fastBool False -#endif -#ifdef REG_D2 -freeReg REG_D2 = fastBool False -#endif -#ifdef REG_Sp -freeReg REG_Sp = fastBool False -#endif -#ifdef REG_Su -freeReg REG_Su = fastBool False -#endif -#ifdef REG_SpLim -freeReg REG_SpLim = fastBool False -#endif -#ifdef REG_Hp -freeReg REG_Hp = fastBool False -#endif -#ifdef REG_HpLim -freeReg REG_HpLim = fastBool False -#endif -freeReg _ = fastBool True - - --- | Returns 'Nothing' if this global register is not stored --- in a real machine register, otherwise returns @'Just' reg@, where --- reg is the machine register it is stored in. - - -#ifdef REG_Base -globalRegMaybe BaseReg = Just (RealRegSingle REG_Base) -#endif -#ifdef REG_R1 -globalRegMaybe (VanillaReg 1 _) = Just (RealRegSingle REG_R1) -#endif -#ifdef REG_R2 -globalRegMaybe (VanillaReg 2 _) = Just (RealRegSingle REG_R2) -#endif -#ifdef REG_R3 -globalRegMaybe (VanillaReg 3 _) = Just (RealRegSingle REG_R3) -#endif -#ifdef REG_R4 -globalRegMaybe (VanillaReg 4 _) = Just (RealRegSingle REG_R4) -#endif -#ifdef REG_R5 -globalRegMaybe (VanillaReg 5 _) = Just (RealRegSingle REG_R5) -#endif -#ifdef REG_R6 -globalRegMaybe (VanillaReg 6 _) = Just (RealRegSingle REG_R6) -#endif -#ifdef REG_R7 -globalRegMaybe (VanillaReg 7 _) = Just (RealRegSingle REG_R7) -#endif -#ifdef REG_R8 -globalRegMaybe (VanillaReg 8 _) = Just (RealRegSingle REG_R8) -#endif -#ifdef REG_R9 -globalRegMaybe (VanillaReg 9 _) = Just (RealRegSingle REG_R9) -#endif -#ifdef REG_R10 -globalRegMaybe (VanillaReg 10 _) = Just (RealRegSingle REG_R10) -#endif -#ifdef REG_F1 -globalRegMaybe (FloatReg 1) = Just (RealRegSingle REG_F1) -#endif -#ifdef REG_F2 -globalRegMaybe (FloatReg 2) = Just (RealRegSingle REG_F2) -#endif -#ifdef REG_F3 -globalRegMaybe (FloatReg 3) = Just (RealRegSingle REG_F3) -#endif -#ifdef REG_F4 -globalRegMaybe (FloatReg 4) = Just (RealRegSingle REG_F4) -#endif -#ifdef REG_D1 -globalRegMaybe (DoubleReg 1) = Just (RealRegSingle REG_D1) -#endif -#ifdef REG_D2 -globalRegMaybe (DoubleReg 2) = Just (RealRegSingle REG_D2) -#endif -#ifdef REG_Sp -globalRegMaybe Sp = Just (RealRegSingle REG_Sp) -#endif -#ifdef REG_Lng1 -globalRegMaybe (LongReg 1) = Just (RealRegSingle REG_Lng1) -#endif -#ifdef REG_Lng2 -globalRegMaybe (LongReg 2) = Just (RealRegSingle REG_Lng2) -#endif -#ifdef REG_SpLim -globalRegMaybe SpLim = Just (RealRegSingle REG_SpLim) -#endif -#ifdef REG_Hp -globalRegMaybe Hp = Just (RealRegSingle REG_Hp) -#endif -#ifdef REG_HpLim -globalRegMaybe HpLim = Just (RealRegSingle REG_HpLim) -#endif -#ifdef REG_CurrentTSO -globalRegMaybe CurrentTSO = Just (RealRegSingle REG_CurrentTSO) -#endif -#ifdef REG_CurrentNursery -globalRegMaybe CurrentNursery = Just (RealRegSingle REG_CurrentNursery) -#endif -globalRegMaybe _ = Nothing - - -#else /* powerpc_TARGET_ARCH */ - -freeReg _ = 0# -globalRegMaybe _ = panic "PPC.Regs.globalRegMaybe: not defined" - -#endif /* powerpc_TARGET_ARCH */ - - -- allocatableRegs is allMachRegNos with the fixed-use regs removed. -- i.e., these are the regs for which we are prepared to allow the -- register allocator to attempt to map VRegs to. -allocatableRegs :: [RealReg] -allocatableRegs - = let isFree i = isFastTrue (freeReg i) +allocatableRegs :: Platform -> [RealReg] +allocatableRegs platform + = let isFree i = isFastTrue (freeReg platform i) in map RealRegSingle $ filter isFree allMachRegNos diff --git a/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs index 724d7d6b25..887af1758a 100644 --- a/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs +++ b/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs @@ -42,27 +42,27 @@ import qualified SPARC.Instr import qualified X86.Instr class Show freeRegs => FR freeRegs where - frAllocateReg :: RealReg -> freeRegs -> freeRegs + frAllocateReg :: Platform -> RealReg -> freeRegs -> freeRegs frGetFreeRegs :: Platform -> RegClass -> freeRegs -> [RealReg] frInitFreeRegs :: Platform -> freeRegs - frReleaseReg :: RealReg -> freeRegs -> freeRegs + frReleaseReg :: Platform -> RealReg -> freeRegs -> freeRegs instance FR X86.FreeRegs where - frAllocateReg = X86.allocateReg + frAllocateReg = \_ -> X86.allocateReg frGetFreeRegs = X86.getFreeRegs frInitFreeRegs = X86.initFreeRegs - frReleaseReg = X86.releaseReg + frReleaseReg = \_ -> X86.releaseReg instance FR PPC.FreeRegs where - frAllocateReg = PPC.allocateReg + frAllocateReg = \_ -> PPC.allocateReg frGetFreeRegs = \_ -> PPC.getFreeRegs - frInitFreeRegs = \_ -> PPC.initFreeRegs - frReleaseReg = PPC.releaseReg + frInitFreeRegs = PPC.initFreeRegs + frReleaseReg = \_ -> PPC.releaseReg instance FR SPARC.FreeRegs where frAllocateReg = SPARC.allocateReg frGetFreeRegs = \_ -> SPARC.getFreeRegs - frInitFreeRegs = \_ -> SPARC.initFreeRegs + frInitFreeRegs = SPARC.initFreeRegs frReleaseReg = SPARC.releaseReg maxSpillSlots :: Platform -> Int diff --git a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs index c17b65d6e2..ea415e2661 100644 --- a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs +++ b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs @@ -135,7 +135,7 @@ joinToTargets_first platform block_live new_blocks block_id instr dest dests = do -- free up the regs that are not live on entry to this block. freeregs <- getFreeRegsR - let freeregs' = foldr frReleaseReg freeregs to_free + let freeregs' = foldr (frReleaseReg platform) freeregs to_free -- remember the current assignment on entry to this block. setBlockAssigR (mapInsert dest (freeregs', src_assig) block_assig) diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs index 54c6990948..c2f89de641 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Main.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs @@ -130,9 +130,6 @@ import Data.Maybe import Data.List import Control.Monad -#include "../includes/stg/HaskellMachRegs.h" - - -- ----------------------------------------------------------------------------- -- Top level of the register allocator @@ -328,7 +325,7 @@ initBlock platform id block_live Nothing -> setFreeRegsR (frInitFreeRegs platform) Just live -> - setFreeRegsR $ foldr frAllocateReg (frInitFreeRegs platform) [ r | RegReal r <- uniqSetToList live ] + setFreeRegsR $ foldr (frAllocateReg platform) (frInitFreeRegs platform) [ r | RegReal r <- uniqSetToList live ] setAssigR emptyRegMap -- load info about register assignments leading into this block. @@ -488,10 +485,10 @@ genRaInsn platform block_live new_instrs block_id instr r_dying w_dying = -- (e) Delete all register assignments for temps which are read -- (only) and die here. Update the free register list. - releaseRegs r_dying + releaseRegs platform r_dying -- (f) Mark regs which are clobbered as unallocatable - clobberRegs real_written + clobberRegs platform real_written -- (g) Allocate registers for temporaries *written* (only) (w_spills, w_allocd) <- @@ -499,7 +496,7 @@ genRaInsn platform block_live new_instrs block_id instr r_dying w_dying = -- (h) Release registers for temps which are written here and not -- used again. - releaseRegs w_dying + releaseRegs platform w_dying let -- (i) Patch the instruction @@ -542,19 +539,19 @@ genRaInsn platform block_live new_instrs block_id instr r_dying w_dying = -- ----------------------------------------------------------------------------- -- releaseRegs -releaseRegs :: FR freeRegs => [Reg] -> RegM freeRegs () -releaseRegs regs = do +releaseRegs :: FR freeRegs => Platform -> [Reg] -> RegM freeRegs () +releaseRegs platform regs = do assig <- getAssigR free <- getFreeRegsR loop assig free regs where loop _ free _ | free `seq` False = undefined loop assig free [] = do setAssigR assig; setFreeRegsR free; return () - loop assig free (RegReal rr : rs) = loop assig (frReleaseReg rr free) rs + loop assig free (RegReal rr : rs) = loop assig (frReleaseReg platform rr free) rs loop assig free (r:rs) = case lookupUFM assig r of - Just (InBoth real _) -> loop (delFromUFM assig r) (frReleaseReg real free) rs - Just (InReg real) -> loop (delFromUFM assig r) (frReleaseReg real free) rs + Just (InBoth real _) -> loop (delFromUFM assig r) (frReleaseReg platform real free) rs + Just (InReg real) -> loop (delFromUFM assig r) (frReleaseReg platform real free) rs _other -> loop (delFromUFM assig r) free rs @@ -612,7 +609,7 @@ saveClobberedTemps platform clobbered dying -- clobbered by this instruction; use it to save the -- clobbered value. (my_reg : _) -> do - setFreeRegsR (frAllocateReg my_reg freeRegs) + setFreeRegsR (frAllocateReg platform my_reg freeRegs) let new_assign = addToUFM assig temp (InReg my_reg) let instr = mkRegRegMoveInstr platform @@ -636,14 +633,14 @@ saveClobberedTemps platform clobbered dying -- | Mark all these real regs as allocated, -- and kick out their vreg assignments. -- -clobberRegs :: FR freeRegs => [RealReg] -> RegM freeRegs () -clobberRegs [] +clobberRegs :: FR freeRegs => Platform -> [RealReg] -> RegM freeRegs () +clobberRegs _ [] = return () -clobberRegs clobbered +clobberRegs platform clobbered = do freeregs <- getFreeRegsR - setFreeRegsR $! foldr frAllocateReg freeregs clobbered + setFreeRegsR $! foldr (frAllocateReg platform) freeregs clobbered assig <- getAssigR setAssigR $! clobber assig (ufmToList assig) @@ -754,7 +751,7 @@ allocRegsAndSpill_spill platform reading keep spills alloc r rs assig spill_loc do spills' <- loadTemp platform r spill_loc my_reg spills setAssigR (addToUFM assig r $! newLocation spill_loc my_reg) - setFreeRegsR $ frAllocateReg my_reg freeRegs + setFreeRegsR $ frAllocateReg platform my_reg freeRegs allocateRegsAndSpill platform reading keep spills' (my_reg : alloc) rs diff --git a/compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs index 10726cd4b4..2c83481f6c 100644 --- a/compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs +++ b/compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs @@ -15,6 +15,7 @@ import RegClass import Reg import Outputable +import Platform import Data.Word import Data.Bits @@ -45,8 +46,8 @@ releaseReg (RealRegSingle r) (FreeRegs g f) releaseReg _ _ = panic "RegAlloc.Linear.PPC.releaseReg: bad reg" -initFreeRegs :: FreeRegs -initFreeRegs = foldr releaseReg noFreeRegs allocatableRegs +initFreeRegs :: Platform -> FreeRegs +initFreeRegs platform = foldr releaseReg noFreeRegs (allocatableRegs platform) getFreeRegs :: RegClass -> FreeRegs -> [RealReg] -- lazilly getFreeRegs cls (FreeRegs g f) diff --git a/compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs index d3bc88c09f..d15ad07898 100644 --- a/compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs +++ b/compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs @@ -11,11 +11,12 @@ module RegAlloc.Linear.SPARC.FreeRegs where import SPARC.Regs -import SPARC.RegPlate import RegClass import Reg +import CodeGen.Platform import Outputable +import Platform import FastBool import Data.Word @@ -50,9 +51,9 @@ noFreeRegs = FreeRegs 0 0 0 -- | The initial set of free regs. -initFreeRegs :: FreeRegs -initFreeRegs - = foldr releaseReg noFreeRegs allocatableRegs +initFreeRegs :: Platform -> FreeRegs +initFreeRegs platform + = foldr (releaseReg platform) noFreeRegs allocatableRegs -- | Get all the free registers of this class. @@ -75,13 +76,13 @@ getFreeRegs cls (FreeRegs g f d) -- | Grab a register. -allocateReg :: RealReg -> FreeRegs -> FreeRegs -allocateReg +allocateReg :: Platform -> RealReg -> FreeRegs -> FreeRegs +allocateReg platform reg@(RealRegSingle r) (FreeRegs g f d) -- can't allocate free regs - | not $ isFastTrue (freeReg r) + | not $ isFastTrue (freeReg platform r) = pprPanic "SPARC.FreeRegs.allocateReg: not allocating pinned reg" (ppr reg) -- a general purpose reg @@ -108,7 +109,7 @@ allocateReg | otherwise = pprPanic "SPARC.FreeRegs.releaseReg: not allocating bad reg" (ppr reg) -allocateReg +allocateReg _ reg@(RealRegPair r1 r2) (FreeRegs g f d) @@ -131,13 +132,13 @@ allocateReg -- The register liveness information says that most regs die after a C call, -- but we still don't want to allocate to some of them. -- -releaseReg :: RealReg -> FreeRegs -> FreeRegs -releaseReg +releaseReg :: Platform -> RealReg -> FreeRegs -> FreeRegs +releaseReg platform reg@(RealRegSingle r) regs@(FreeRegs g f d) -- don't release pinned reg - | not $ isFastTrue (freeReg r) + | not $ isFastTrue (freeReg platform r) = regs -- a general purpose reg @@ -161,7 +162,7 @@ releaseReg | otherwise = pprPanic "SPARC.FreeRegs.releaseReg: not releasing bad reg" (ppr reg) -releaseReg +releaseReg _ reg@(RealRegPair r1 r2) (FreeRegs g f d) diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs index 840918281f..a3409dd28b 100644 --- a/compiler/nativeGen/SPARC/CodeGen.hs +++ b/compiler/nativeGen/SPARC/CodeGen.hs @@ -191,12 +191,12 @@ assignMem_IntCode pk addr src = do assignReg_IntCode :: Size -> CmmReg -> CmmExpr -> NatM InstrBlock assignReg_IntCode _ reg src = do + dflags <- getDynFlags r <- getRegister src + let dst = getRegisterReg (targetPlatform dflags) reg return $ case r of Any _ code -> code dst Fixed _ freg fcode -> fcode `snocOL` OR False g0 (RIReg freg) dst - where - dst = getRegisterReg reg @@ -218,8 +218,10 @@ assignMem_FltCode pk addr src = do -- Floating point assignment to a register/temporary assignReg_FltCode :: Size -> CmmReg -> CmmExpr -> NatM InstrBlock assignReg_FltCode pk dstCmmReg srcCmmExpr = do + dflags <- getDynFlags + let platform = targetPlatform dflags srcRegister <- getRegister srcCmmExpr - let dstReg = getRegisterReg dstCmmReg + let dstReg = getRegisterReg platform dstCmmReg return $ case srcRegister of Any _ code -> code dstReg @@ -537,7 +539,7 @@ assign_code _ [] = nilOL assign_code platform [CmmHinted dest _hint] = let rep = localRegType dest width = typeWidth rep - r_dest = getRegisterReg (CmmLocal dest) + r_dest = getRegisterReg platform (CmmLocal dest) result | isFloatType rep diff --git a/compiler/nativeGen/SPARC/CodeGen/Base.hs b/compiler/nativeGen/SPARC/CodeGen/Base.hs index 8990072c3f..469361139b 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Base.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Base.hs @@ -25,12 +25,13 @@ import SPARC.Instr import SPARC.Cond import SPARC.AddrMode import SPARC.Regs -import SPARC.RegPlate import Size import Reg +import CodeGen.Platform import OldCmm import OldPprCmm () +import Platform import Outputable import OrdList @@ -98,13 +99,13 @@ setSizeOfRegister reg size -------------------------------------------------------------------------------- -- | Grab the Reg for a CmmReg -getRegisterReg :: CmmReg -> Reg +getRegisterReg :: Platform -> CmmReg -> Reg -getRegisterReg (CmmLocal (LocalReg u pk)) +getRegisterReg _ (CmmLocal (LocalReg u pk)) = RegVirtual $ mkVirtualReg u (cmmTypeSize pk) -getRegisterReg (CmmGlobal mid) - = case globalRegMaybe mid of +getRegisterReg platform (CmmGlobal mid) + = case globalRegMaybe platform mid of Just reg -> RegReal reg Nothing -> pprPanic "SPARC.CodeGen.Base.getRegisterReg: global is in memory" diff --git a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs index 454e786f1a..c2c47e99aa 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs @@ -32,6 +32,7 @@ import Reg import OldCmm import Control.Monad (liftM) +import DynFlags import OrdList import Outputable @@ -54,8 +55,10 @@ getSomeReg expr = do getRegister :: CmmExpr -> NatM Register getRegister (CmmReg reg) - = return (Fixed (cmmTypeSize (cmmRegType reg)) - (getRegisterReg reg) nilOL) + = do dflags <- getDynFlags + let platform = targetPlatform dflags + return (Fixed (cmmTypeSize (cmmRegType reg)) + (getRegisterReg platform reg) nilOL) getRegister tree@(CmmRegOff _ _) = getRegister (mangleIndexTree tree) diff --git a/compiler/nativeGen/SPARC/Instr.hs b/compiler/nativeGen/SPARC/Instr.hs index b3429f7587..021b2fb772 100644 --- a/compiler/nativeGen/SPARC/Instr.hs +++ b/compiler/nativeGen/SPARC/Instr.hs @@ -36,7 +36,6 @@ import SPARC.Imm import SPARC.AddrMode import SPARC.Cond import SPARC.Regs -import SPARC.RegPlate import SPARC.Base import TargetReg import Instruction @@ -45,6 +44,7 @@ import Reg import Size import CLabel +import CodeGen.Platform import BlockId import OldCmm import FastString @@ -222,7 +222,7 @@ data Instr -- allocation goes, are taken care of by the register allocator. -- sparc_regUsageOfInstr :: Platform -> Instr -> RegUsage -sparc_regUsageOfInstr _ instr +sparc_regUsageOfInstr platform instr = case instr of LD _ addr reg -> usage (regAddr addr, [reg]) ST _ reg addr -> usage (reg : regAddr addr, []) @@ -266,7 +266,8 @@ sparc_regUsageOfInstr _ instr where usage (src, dst) - = RU (filter interesting src) (filter interesting dst) + = RU (filter (interesting platform) src) + (filter (interesting platform) dst) regAddr (AddrRegReg r1 r2) = [r1, r2] regAddr (AddrRegImm r1 _) = [r1] @@ -277,12 +278,12 @@ sparc_regUsageOfInstr _ instr -- | Interesting regs are virtuals, or ones that are allocatable -- by the register allocator. -interesting :: Reg -> Bool -interesting reg +interesting :: Platform -> Reg -> Bool +interesting platform reg = case reg of RegVirtual _ -> True - RegReal (RealRegSingle r1) -> isFastTrue (freeReg r1) - RegReal (RealRegPair r1 _) -> isFastTrue (freeReg r1) + RegReal (RealRegSingle r1) -> isFastTrue (freeReg platform r1) + RegReal (RealRegPair r1 _) -> isFastTrue (freeReg platform r1) diff --git a/compiler/nativeGen/SPARC/RegPlate.hs b/compiler/nativeGen/SPARC/RegPlate.hs deleted file mode 100644 index be638a934b..0000000000 --- a/compiler/nativeGen/SPARC/RegPlate.hs +++ /dev/null @@ -1,318 +0,0 @@ - -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - --- | Nasty #ifdefery that generates the definitions for --- freeReg and globalRegMaybe from the information in includes/MachRegs.h. --- --- If the current TARGET_ARCH isn't sparc then these functions will be wrong. --- -module SPARC.RegPlate ( - freeReg, - globalRegMaybe -) - -where - -#include "HsVersions.h" - -import Reg -import CmmExpr -import FastBool - --- Register numbers for SPARC hardware registers. --- These names are the same as the ones in Regs.hs, but those have --- type Reg and not RegNo. --- -#ifdef sparc_TARGET_ARCH - -#define g0 0 -#define g1 1 -#define g2 2 -#define g3 3 -#define g4 4 -#define g5 5 -#define g6 6 -#define g7 7 - -#define o0 8 -#define o1 9 -#define o2 10 -#define o3 11 -#define o4 12 -#define o5 13 -#define o6 14 -#define o7 15 - -#define l0 16 -#define l1 17 -#define l2 18 -#define l3 19 -#define l4 20 -#define l5 21 -#define l6 22 -#define l7 23 - -#define i0 24 -#define i1 25 -#define i2 26 -#define i3 27 -#define i4 28 -#define i5 29 -#define i6 30 -#define i7 31 - -#define f0 32 -#define f1 33 -#define f2 34 -#define f3 35 -#define f4 36 -#define f5 37 -#define f6 38 -#define f7 39 -#define f8 40 -#define f9 41 -#define f10 42 -#define f11 43 -#define f12 44 -#define f13 45 -#define f14 46 -#define f15 47 -#define f16 48 -#define f17 49 -#define f18 50 -#define f19 51 -#define f20 52 -#define f21 53 -#define f22 54 -#define f23 55 -#define f24 56 -#define f25 57 -#define f26 58 -#define f27 59 -#define f28 60 -#define f29 61 -#define f30 62 -#define f31 63 - - -#include "../includes/stg/HaskellMachRegs.h" - --- | Check whether a machine register is free for allocation. -freeReg :: RegNo -> FastBool - - --- SPARC regs used by the OS / ABI --- %g0(r0) is always zero -freeReg g0 = fastBool False - --- %g5(r5) - %g7(r7) --- are reserved for the OS -freeReg g5 = fastBool False -freeReg g6 = fastBool False -freeReg g7 = fastBool False - --- %o6(r14) --- is the C stack pointer -freeReg o6 = fastBool False - --- %o7(r15) --- holds the C return address -freeReg o7 = fastBool False - --- %i6(r30) --- is the C frame pointer -freeReg i6 = fastBool False - --- %i7(r31) --- is used for C return addresses -freeReg i7 = fastBool False - --- %f0(r32) - %f1(r32) --- are C floating point return regs -freeReg f0 = fastBool False -freeReg f1 = fastBool False - -{- -freeReg regNo - -- don't release high half of double regs - | regNo >= f0 - , regNo < NCG_FirstFloatReg - , regNo `mod` 2 /= 0 - = fastBool False --} --------------------------------------- - - -#ifdef REG_Base -freeReg REG_Base = fastBool False -#endif -#ifdef REG_R1 -freeReg REG_R1 = fastBool False -#endif -#ifdef REG_R2 -freeReg REG_R2 = fastBool False -#endif -#ifdef REG_R3 -freeReg REG_R3 = fastBool False -#endif -#ifdef REG_R4 -freeReg REG_R4 = fastBool False -#endif -#ifdef REG_R5 -freeReg REG_R5 = fastBool False -#endif -#ifdef REG_R6 -freeReg REG_R6 = fastBool False -#endif -#ifdef REG_R7 -freeReg REG_R7 = fastBool False -#endif -#ifdef REG_R8 -freeReg REG_R8 = fastBool False -#endif -#ifdef REG_R9 -freeReg REG_R9 = fastBool False -#endif -#ifdef REG_R10 -freeReg REG_R10 = fastBool False -#endif -#ifdef REG_F1 -freeReg REG_F1 = fastBool False -#endif -#ifdef REG_F2 -freeReg REG_F2 = fastBool False -#endif -#ifdef REG_F3 -freeReg REG_F3 = fastBool False -#endif -#ifdef REG_F4 -freeReg REG_F4 = fastBool False -#endif -#ifdef REG_D1 -freeReg REG_D1 = fastBool False -#endif -#ifdef REG_D1_2 -freeReg REG_D1_2 = fastBool False -#endif -#ifdef REG_D2 -freeReg REG_D2 = fastBool False -#endif -#ifdef REG_D2_2 -freeReg REG_D2_2 = fastBool False -#endif -#ifdef REG_Sp -freeReg REG_Sp = fastBool False -#endif -#ifdef REG_Su -freeReg REG_Su = fastBool False -#endif -#ifdef REG_SpLim -freeReg REG_SpLim = fastBool False -#endif -#ifdef REG_Hp -freeReg REG_Hp = fastBool False -#endif -#ifdef REG_HpLim -freeReg REG_HpLim = fastBool False -#endif -freeReg _ = fastBool True - - - --- | Returns 'Nothing' if this global register is not stored --- in a real machine register, otherwise returns @'Just' reg@, where --- reg is the machine register it is stored in. - - -globalRegMaybe :: GlobalReg -> Maybe RealReg - -#ifdef REG_Base -globalRegMaybe BaseReg = Just (RealRegSingle REG_Base) -#endif -#ifdef REG_R1 -globalRegMaybe (VanillaReg 1 _) = Just (RealRegSingle REG_R1) -#endif -#ifdef REG_R2 -globalRegMaybe (VanillaReg 2 _) = Just (RealRegSingle REG_R2) -#endif -#ifdef REG_R3 -globalRegMaybe (VanillaReg 3 _) = Just (RealRegSingle REG_R3) -#endif -#ifdef REG_R4 -globalRegMaybe (VanillaReg 4 _) = Just (RealRegSingle REG_R4) -#endif -#ifdef REG_R5 -globalRegMaybe (VanillaReg 5 _) = Just (RealRegSingle REG_R5) -#endif -#ifdef REG_R6 -globalRegMaybe (VanillaReg 6 _) = Just (RealRegSingle REG_R6) -#endif -#ifdef REG_R7 -globalRegMaybe (VanillaReg 7 _) = Just (RealRegSingle REG_R7) -#endif -#ifdef REG_R8 -globalRegMaybe (VanillaReg 8 _) = Just (RealRegSingle REG_R8) -#endif -#ifdef REG_R9 -globalRegMaybe (VanillaReg 9 _) = Just (RealRegSingle REG_R9) -#endif -#ifdef REG_R10 -globalRegMaybe (VanillaReg 10 _) = Just (RealRegSingle REG_R10) -#endif -#ifdef REG_F1 -globalRegMaybe (FloatReg 1) = Just (RealRegSingle REG_F1) -#endif -#ifdef REG_F2 -globalRegMaybe (FloatReg 2) = Just (RealRegSingle REG_F2) -#endif -#ifdef REG_F3 -globalRegMaybe (FloatReg 3) = Just (RealRegSingle REG_F3) -#endif -#ifdef REG_F4 -globalRegMaybe (FloatReg 4) = Just (RealRegSingle REG_F4) -#endif -#ifdef REG_D1 -globalRegMaybe (DoubleReg 1) = Just (RealRegPair REG_D1 (REG_D1 + 1)) -#endif -#ifdef REG_D2 -globalRegMaybe (DoubleReg 2) = Just (RealRegPair REG_D2 (REG_D2 + 1)) -#endif -#ifdef REG_Sp -globalRegMaybe Sp = Just (RealRegSingle REG_Sp) -#endif -#ifdef REG_Lng1 -globalRegMaybe (LongReg 1) = Just (RealRegSingle REG_Lng1) -#endif -#ifdef REG_Lng2 -globalRegMaybe (LongReg 2) = Just (RealRegSingle REG_Lng2) -#endif -#ifdef REG_SpLim -globalRegMaybe SpLim = Just (RealRegSingle REG_SpLim) -#endif -#ifdef REG_Hp -globalRegMaybe Hp = Just (RealRegSingle REG_Hp) -#endif -#ifdef REG_HpLim -globalRegMaybe HpLim = Just (RealRegSingle REG_HpLim) -#endif -#ifdef REG_CurrentTSO -globalRegMaybe CurrentTSO = Just (RealRegSingle REG_CurrentTSO) -#endif -#ifdef REG_CurrentNursery -globalRegMaybe CurrentNursery = Just (RealRegSingle REG_CurrentNursery) -#endif -globalRegMaybe _ = Nothing - -#else -freeReg :: RegNo -> FastBool -freeReg = error "SPARC.RegPlate.freeReg: not defined" - -globalRegMaybe :: GlobalReg -> Maybe RealReg -globalRegMaybe = error "SPARC.RegPlate.globalRegMaybe: not defined" - -#endif diff --git a/compiler/nativeGen/SPARC/Regs.hs b/compiler/nativeGen/SPARC/Regs.hs index ff899c24b1..d1ac2b4cb3 100644 --- a/compiler/nativeGen/SPARC/Regs.hs +++ b/compiler/nativeGen/SPARC/Regs.hs @@ -39,13 +39,11 @@ module SPARC.Regs ( where -import SPARC.RegPlate +import CodeGen.Platform.SPARC import Reg import RegClass import Size --- import PprCmm () - import Unique import Outputable import FastTypes @@ -274,129 +272,3 @@ regDotColor reg RcFloat -> text "red" _other -> text "green" - - - --- Hard coded freeReg / globalRegMaybe ----------------------------------------- --- This isn't being used at the moment because we're generating --- these functions from the information in --- includes/stg/MachRegs.hs via RegPlate.hs - --- | Check whether a machine register is free for allocation. --- This needs to match the info in includes/stg/MachRegs.h --- otherwise modules compiled with the NCG won't be compatible --- with via-C ones. --- -{- -freeReg :: RegNo -> FastBool -freeReg regno - = case regno of - -- %g0(r0) is always 0. - 0 -> fastBool False - - -- %g1(r1) - %g4(r4) are allocable ----------------- - - -- %g5(r5) - %g7(r7) - -- are reserved for the OS - 5 -> fastBool False - 6 -> fastBool False - 7 -> fastBool False - - -- %o0(r8) - %o5(r13) are allocable ---------------- - - -- %o6(r14) - -- is the C stack pointer - 14 -> fastBool False - - -- %o7(r15) - -- holds C return addresses (???) - 15 -> fastBool False - - -- %l0(r16) is allocable --------------------------- - - -- %l1(r17) - %l5(r21) - -- are STG regs R1 - R5 - 17 -> fastBool False - 18 -> fastBool False - 19 -> fastBool False - 20 -> fastBool False - 21 -> fastBool False - - -- %l6(r22) - %l7(r23) are allocable -------------- - - -- %i0(r24) - %i5(r29) - -- are STG regs Sp, Base, SpLim, Hp, R6 - 24 -> fastBool False - 25 -> fastBool False - 26 -> fastBool False - 27 -> fastBool False - - -- %i5(r28) is allocable -------------------------- - - 29 -> fastBool False - - -- %i6(r30) - -- is the C frame pointer - 30 -> fastBool False - - -- %i7(r31) - -- is used for C return addresses - 31 -> fastBool False - - -- %f0(r32) - %f1(r33) - -- are C fp return registers - 32 -> fastBool False - 33 -> fastBool False - - -- %f2(r34) - %f5(r37) - -- are STG regs D1 - D2 - 34 -> fastBool False - 35 -> fastBool False - 36 -> fastBool False - 37 -> fastBool False - - -- %f22(r54) - %f25(r57) - -- are STG regs F1 - F4 - 54 -> fastBool False - 55 -> fastBool False - 56 -> fastBool False - 57 -> fastBool False - - -- regs not matched above are allocable. - _ -> fastBool True - --} - --- | Returns Just the real register that a global register is stored in. --- Returns Nothing if the global has no real register, and is stored --- in the in-memory register table instead. --- -{- -globalRegMaybe :: GlobalReg -> Maybe Reg -globalRegMaybe gg - = case gg of - -- Argument and return regs - VanillaReg 1 _ -> Just (RealReg 17) -- %l1 - VanillaReg 2 _ -> Just (RealReg 18) -- %l2 - VanillaReg 3 _ -> Just (RealReg 19) -- %l3 - VanillaReg 4 _ -> Just (RealReg 20) -- %l4 - VanillaReg 5 _ -> Just (RealReg 21) -- %l5 - VanillaReg 6 _ -> Just (RealReg 29) -- %i5 - - FloatReg 1 -> Just (RealReg 54) -- %f22 - FloatReg 2 -> Just (RealReg 55) -- %f23 - FloatReg 3 -> Just (RealReg 56) -- %f24 - FloatReg 4 -> Just (RealReg 57) -- %f25 - - DoubleReg 1 -> Just (RealReg 34) -- %f2 - DoubleReg 2 -> Just (RealReg 36) -- %f4 - - -- STG Regs - Sp -> Just (RealReg 24) -- %i0 - SpLim -> Just (RealReg 26) -- %i2 - Hp -> Just (RealReg 27) -- %i3 - - BaseReg -> Just (RealReg 25) -- %i1 - - _ -> Nothing --} diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index c00a0d544a..e8f2eccd6b 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -27,6 +27,7 @@ import X86.Instr import X86.Cond import X86.Regs import X86.RegInfo +import CodeGen.Platform import CPrim import Instruction import PIC @@ -166,14 +167,16 @@ stmtToInstrs stmt = do CmmCondBranch arg id -> genCondJump id arg CmmSwitch arg ids -> do dflags <- getDynFlags genSwitch dflags arg ids - CmmJump arg gregs -> genJump arg (jumpRegs gregs) + CmmJump arg gregs -> do dflags <- getDynFlags + let platform = targetPlatform dflags + genJump arg (jumpRegs platform gregs) CmmReturn -> panic "stmtToInstrs: return statement should have been cps'd away" -jumpRegs :: Maybe [GlobalReg] -> [Reg] -jumpRegs Nothing = allHaskellArgRegs -jumpRegs (Just gregs) = [ RegReal r | Just r <- map globalRegMaybe gregs ] +jumpRegs :: Platform -> Maybe [GlobalReg] -> [Reg] +jumpRegs platform Nothing = allHaskellArgRegs platform +jumpRegs platform (Just gregs) = [ RegReal r | Just r <- map (globalRegMaybe platform) gregs ] -------------------------------------------------------------------------------- -- | 'InstrBlock's are the insn sequences generated by the insn selectors. @@ -219,16 +222,16 @@ swizzleRegisterRep (Any _ codefn) size = Any size codefn -- | Grab the Reg for a CmmReg -getRegisterReg :: Bool -> CmmReg -> Reg +getRegisterReg :: Platform -> Bool -> CmmReg -> Reg -getRegisterReg use_sse2 (CmmLocal (LocalReg u pk)) +getRegisterReg _ use_sse2 (CmmLocal (LocalReg u pk)) = let sz = cmmTypeSize pk in if isFloatSize sz && not use_sse2 then RegVirtual (mkVirtualReg u FF80) else RegVirtual (mkVirtualReg u sz) -getRegisterReg _ (CmmGlobal mid) - = case globalRegMaybe mid of +getRegisterReg platform _ (CmmGlobal mid) + = case globalRegMaybe platform mid of Just reg -> RegReal $ reg Nothing -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid) -- By this stage, the only MagicIds remaining should be the @@ -424,7 +427,9 @@ getRegister' is32Bit (CmmReg reg) size | not use_sse2 && isFloatSize sz = FF80 | otherwise = sz -- - return (Fixed size (getRegisterReg use_sse2 reg) nilOL) + dflags <- getDynFlags + let platform = targetPlatform dflags + return (Fixed size (getRegisterReg platform use_sse2 reg) nilOL) getRegister' is32Bit (CmmRegOff r n) @@ -1052,9 +1057,11 @@ getNonClobberedOperand (CmmLoad mem pk) = do if (not (isFloatType pk) || use_sse2) && (if is32Bit then not (isWord64 pk) else True) then do + dflags <- getDynFlags + let platform = targetPlatform dflags Amode src mem_code <- getAmode mem (src',save_code) <- - if (amodeCouldBeClobbered src) + if (amodeCouldBeClobbered platform src) then do tmp <- getNewRegNat (archWordSize is32Bit) return (AddrBaseIndex (EABaseReg tmp) EAIndexNone (ImmInt 0), @@ -1072,12 +1079,12 @@ getNonClobberedOperand_generic e = do (reg, code) <- getNonClobberedReg e return (OpReg reg, code) -amodeCouldBeClobbered :: AddrMode -> Bool -amodeCouldBeClobbered amode = any regClobbered (addrModeRegs amode) +amodeCouldBeClobbered :: Platform -> AddrMode -> Bool +amodeCouldBeClobbered platform amode = any (regClobbered platform) (addrModeRegs amode) -regClobbered :: Reg -> Bool -regClobbered (RegReal (RealRegSingle rr)) = isFastTrue (freeReg rr) -regClobbered _ = False +regClobbered :: Platform -> Reg -> Bool +regClobbered platform (RegReal (RealRegSingle rr)) = isFastTrue (freeReg platform rr) +regClobbered _ _ = False -- getOperand: the operand is not required to remain valid across the -- computation of an arbitrary expression. @@ -1385,12 +1392,16 @@ assignMem_IntCode pk addr src = do -- Assign; dst is a reg, rhs is mem assignReg_IntCode pk reg (CmmLoad src _) = do load_code <- intLoadCode (MOV pk) src - return (load_code (getRegisterReg False{-no sse2-} reg)) + dflags <- getDynFlags + let platform = targetPlatform dflags + return (load_code (getRegisterReg platform False{-no sse2-} reg)) -- dst is a reg, but src could be anything assignReg_IntCode _ reg src = do + dflags <- getDynFlags + let platform = targetPlatform dflags code <- getAnyReg src - return (code (getRegisterReg False{-no sse2-} reg)) + return (code (getRegisterReg platform False{-no sse2-} reg)) -- Floating point assignment to memory @@ -1409,7 +1420,9 @@ assignMem_FltCode pk addr src = do assignReg_FltCode _ reg src = do use_sse2 <- sse2Enabled src_code <- getAnyReg src - return (src_code (getRegisterReg use_sse2 reg)) + dflags <- getDynFlags + let platform = targetPlatform dflags + return (src_code (getRegisterReg platform use_sse2 reg)) genJump :: CmmExpr{-the branch target-} -> [Reg] -> NatM InstrBlock @@ -1594,6 +1607,8 @@ genCCall _ (CmmPrim MO_WriteBarrier _) _ _ = return nilOL genCCall is32Bit (CmmPrim (MO_PopCnt width) _) dest_regs@[CmmHinted dst _] args@[CmmHinted src _] = do sse4_2 <- sse4_2Enabled + dflags <- getDynFlags + let platform = targetPlatform dflags if sse4_2 then do code_src <- getAnyReg src src_r <- getNewRegNat size @@ -1602,12 +1617,11 @@ genCCall is32Bit (CmmPrim (MO_PopCnt width) _) dest_regs@[CmmHinted dst _] -- The POPCNT instruction doesn't take a r/m8 unitOL (MOVZxL II8 (OpReg src_r) (OpReg src_r)) `appOL` unitOL (POPCNT II16 (OpReg src_r) - (getRegisterReg False (CmmLocal dst))) + (getRegisterReg platform False (CmmLocal dst))) else unitOL (POPCNT size (OpReg src_r) - (getRegisterReg False (CmmLocal dst)))) + (getRegisterReg platform False (CmmLocal dst)))) else do - dflags <- getDynFlags targetExpr <- cmmMakeDynamicReference dflags addImportNat CallReference lbl let target = CmmCallee targetExpr CCallConv @@ -1624,8 +1638,10 @@ genCCall32 :: CmmCallTarget -- function to call -> [HintedCmmFormal] -- where to put the result -> [HintedCmmActual] -- arguments (of mixed type) -> NatM InstrBlock -genCCall32 target dest_regs args = - case (target, dest_regs) of +genCCall32 target dest_regs args = do + dflags <- getDynFlags + let platform = targetPlatform dflags + case (target, dest_regs) of -- void return type prim op (CmmPrim op _, []) -> outOfLineCmmOp op Nothing args @@ -1656,23 +1672,23 @@ genCCall32 target dest_regs args = actuallyInlineFloatOp instr size [CmmHinted x _] = do res <- trivialUFCode size (instr size) x any <- anyReg res - return (any (getRegisterReg False (CmmLocal r))) + return (any (getRegisterReg platform False (CmmLocal r))) actuallyInlineFloatOp _ _ args = panic $ "genCCall32.actuallyInlineFloatOp: bad number of arguments! (" ++ show (length args) ++ ")" - (CmmPrim (MO_S_QuotRem width) _, _) -> divOp1 True width dest_regs args - (CmmPrim (MO_U_QuotRem width) _, _) -> divOp1 False width dest_regs args - (CmmPrim (MO_U_QuotRem2 width) _, _) -> divOp2 False width dest_regs args + (CmmPrim (MO_S_QuotRem width) _, _) -> divOp1 platform True width dest_regs args + (CmmPrim (MO_U_QuotRem width) _, _) -> divOp1 platform False width dest_regs args + (CmmPrim (MO_U_QuotRem2 width) _, _) -> divOp2 platform False width dest_regs args (CmmPrim (MO_Add2 width) _, [CmmHinted res_h _, CmmHinted res_l _]) -> case args of [CmmHinted arg_x _, CmmHinted arg_y _] -> do hCode <- getAnyReg (CmmLit (CmmInt 0 width)) lCode <- getAnyReg (CmmMachOp (MO_Add width) [arg_x, arg_y]) let size = intSize width - reg_l = getRegisterReg True (CmmLocal res_l) - reg_h = getRegisterReg True (CmmLocal res_h) + reg_l = getRegisterReg platform True (CmmLocal res_l) + reg_h = getRegisterReg platform True (CmmLocal res_h) code = hCode reg_h `appOL` lCode reg_l `snocOL` ADC size (OpImm (ImmInteger 0)) (OpReg reg_h) @@ -1684,8 +1700,8 @@ genCCall32 target dest_regs args = do (y_reg, y_code) <- getRegOrMem arg_y x_code <- getAnyReg arg_x let size = intSize width - reg_h = getRegisterReg True (CmmLocal res_h) - reg_l = getRegisterReg True (CmmLocal res_l) + reg_h = getRegisterReg platform True (CmmLocal res_h) + reg_l = getRegisterReg platform True (CmmLocal res_l) code = y_code `appOL` x_code rax `appOL` toOL [MUL2 size y_reg, @@ -1699,21 +1715,21 @@ genCCall32 target dest_regs args = _ -> genCCall32' target dest_regs args - where divOp1 signed width results [CmmHinted arg_x _, CmmHinted arg_y _] - = divOp signed width results Nothing arg_x arg_y - divOp1 _ _ _ _ + where divOp1 platform signed width results [CmmHinted arg_x _, CmmHinted arg_y _] + = divOp platform signed width results Nothing arg_x arg_y + divOp1 _ _ _ _ _ = panic "genCCall32: Wrong number of arguments for divOp1" - divOp2 signed width results [CmmHinted arg_x_high _, - CmmHinted arg_x_low _, - CmmHinted arg_y _] - = divOp signed width results (Just arg_x_high) arg_x_low arg_y - divOp2 _ _ _ _ + divOp2 platform signed width results [CmmHinted arg_x_high _, + CmmHinted arg_x_low _, + CmmHinted arg_y _] + = divOp platform signed width results (Just arg_x_high) arg_x_low arg_y + divOp2 _ _ _ _ _ = panic "genCCall64: Wrong number of arguments for divOp2" - divOp signed width [CmmHinted res_q _, CmmHinted res_r _] - m_arg_x_high arg_x_low arg_y + divOp platform signed width [CmmHinted res_q _, CmmHinted res_r _] + m_arg_x_high arg_x_low arg_y = do let size = intSize width - reg_q = getRegisterReg True (CmmLocal res_q) - reg_r = getRegisterReg True (CmmLocal res_r) + reg_q = getRegisterReg platform True (CmmLocal res_q) + reg_r = getRegisterReg platform True (CmmLocal res_r) widen | signed = CLTD size | otherwise = XOR size (OpReg rdx) (OpReg rdx) instr | signed = IDIV @@ -1731,7 +1747,7 @@ genCCall32 target dest_regs args = toOL [instr size y_reg, MOV size (OpReg rax) (OpReg reg_q), MOV size (OpReg rdx) (OpReg reg_r)] - divOp _ _ _ _ _ _ + divOp _ _ _ _ _ _ _ = panic "genCCall32: Wrong number of results for divOp" genCCall32' :: CmmCallTarget -- function to call @@ -1795,6 +1811,9 @@ genCCall32' target dest_regs args = do ) setDeltaNat delta0 + dflags <- getDynFlags + let platform = targetPlatform dflags + let -- assign the results, if necessary assign_code [] = nilOL @@ -1820,7 +1839,7 @@ genCCall32' target dest_regs args = do w = typeWidth ty b = widthInBytes w r_dest_hi = getHiVRegFromLo r_dest - r_dest = getRegisterReg use_sse2 (CmmLocal dest) + r_dest = getRegisterReg platform use_sse2 (CmmLocal dest) assign_code many = pprPanic "genCCall.assign_code - too many return values:" (ppr many) return (push_code `appOL` @@ -1884,8 +1903,10 @@ genCCall64 :: CmmCallTarget -- function to call -> [HintedCmmFormal] -- where to put the result -> [HintedCmmActual] -- arguments (of mixed type) -> NatM InstrBlock -genCCall64 target dest_regs args = - case (target, dest_regs) of +genCCall64 target dest_regs args = do + dflags <- getDynFlags + let platform = targetPlatform dflags + case (target, dest_regs) of (CmmPrim op _, []) -> -- void return type prim op @@ -1895,17 +1916,17 @@ genCCall64 target dest_regs args = -- we only cope with a single result for foreign calls outOfLineCmmOp op (Just res) args - (CmmPrim (MO_S_QuotRem width) _, _) -> divOp1 True width dest_regs args - (CmmPrim (MO_U_QuotRem width) _, _) -> divOp1 False width dest_regs args - (CmmPrim (MO_U_QuotRem2 width) _, _) -> divOp2 False width dest_regs args + (CmmPrim (MO_S_QuotRem width) _, _) -> divOp1 platform True width dest_regs args + (CmmPrim (MO_U_QuotRem width) _, _) -> divOp1 platform False width dest_regs args + (CmmPrim (MO_U_QuotRem2 width) _, _) -> divOp2 platform False width dest_regs args (CmmPrim (MO_Add2 width) _, [CmmHinted res_h _, CmmHinted res_l _]) -> case args of [CmmHinted arg_x _, CmmHinted arg_y _] -> do hCode <- getAnyReg (CmmLit (CmmInt 0 width)) lCode <- getAnyReg (CmmMachOp (MO_Add width) [arg_x, arg_y]) let size = intSize width - reg_l = getRegisterReg True (CmmLocal res_l) - reg_h = getRegisterReg True (CmmLocal res_h) + reg_l = getRegisterReg platform True (CmmLocal res_l) + reg_h = getRegisterReg platform True (CmmLocal res_h) code = hCode reg_h `appOL` lCode reg_l `snocOL` ADC size (OpImm (ImmInteger 0)) (OpReg reg_h) @@ -1917,8 +1938,8 @@ genCCall64 target dest_regs args = do (y_reg, y_code) <- getRegOrMem arg_y x_code <- getAnyReg arg_x let size = intSize width - reg_h = getRegisterReg True (CmmLocal res_h) - reg_l = getRegisterReg True (CmmLocal res_l) + reg_h = getRegisterReg platform True (CmmLocal res_h) + reg_l = getRegisterReg platform True (CmmLocal res_l) code = y_code `appOL` x_code rax `appOL` toOL [MUL2 size y_reg, @@ -1935,21 +1956,21 @@ genCCall64 target dest_regs args = let platform = targetPlatform dflags genCCall64' platform target dest_regs args - where divOp1 signed width results [CmmHinted arg_x _, CmmHinted arg_y _] - = divOp signed width results Nothing arg_x arg_y - divOp1 _ _ _ _ + where divOp1 platform signed width results [CmmHinted arg_x _, CmmHinted arg_y _] + = divOp platform signed width results Nothing arg_x arg_y + divOp1 _ _ _ _ _ = panic "genCCall64: Wrong number of arguments for divOp1" - divOp2 signed width results [CmmHinted arg_x_high _, - CmmHinted arg_x_low _, - CmmHinted arg_y _] - = divOp signed width results (Just arg_x_high) arg_x_low arg_y - divOp2 _ _ _ _ + divOp2 platform signed width results [CmmHinted arg_x_high _, + CmmHinted arg_x_low _, + CmmHinted arg_y _] + = divOp platform signed width results (Just arg_x_high) arg_x_low arg_y + divOp2 _ _ _ _ _ = panic "genCCall64: Wrong number of arguments for divOp2" - divOp signed width [CmmHinted res_q _, CmmHinted res_r _] - m_arg_x_high arg_x_low arg_y + divOp platform signed width [CmmHinted res_q _, CmmHinted res_r _] + m_arg_x_high arg_x_low arg_y = do let size = intSize width - reg_q = getRegisterReg True (CmmLocal res_q) - reg_r = getRegisterReg True (CmmLocal res_r) + reg_q = getRegisterReg platform True (CmmLocal res_q) + reg_r = getRegisterReg platform True (CmmLocal res_r) widen | signed = CLTD size | otherwise = XOR size (OpReg rdx) (OpReg rdx) instr | signed = IDIV @@ -1965,7 +1986,7 @@ genCCall64 target dest_regs args = toOL [instr size y_reg, MOV size (OpReg rax) (OpReg reg_q), MOV size (OpReg rdx) (OpReg reg_r)] - divOp _ _ _ _ _ _ + divOp _ _ _ _ _ _ _ = panic "genCCall64: Wrong number of results for divOp" genCCall64' :: Platform @@ -2065,7 +2086,7 @@ genCCall64' platform target dest_regs args = do _ -> unitOL (MOV (cmmTypeSize rep) (OpReg rax) (OpReg r_dest)) where rep = localRegType dest - r_dest = getRegisterReg True (CmmLocal dest) + r_dest = getRegisterReg platform True (CmmLocal dest) assign_code _many = panic "genCCall.assign_code many" return (load_args_code `appOL` diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs index 91d6ae4479..a2263b3116 100644 --- a/compiler/nativeGen/X86/Instr.hs +++ b/compiler/nativeGen/X86/Instr.hs @@ -24,6 +24,7 @@ import Reg import TargetReg import BlockId +import CodeGen.Platform import OldCmm import FastString import FastBool @@ -449,16 +450,16 @@ x86_regUsageOfInstr platform instr use_index (EAIndex i _) tl = i : tl mkRUR src = src' `seq` RU src' [] - where src' = filter interesting src + where src' = filter (interesting platform) src mkRU src dst = src' `seq` dst' `seq` RU src' dst' - where src' = filter interesting src - dst' = filter interesting dst + where src' = filter (interesting platform) src + dst' = filter (interesting platform) dst -interesting :: Reg -> Bool -interesting (RegVirtual _) = True -interesting (RegReal (RealRegSingle i)) = isFastTrue (freeReg i) -interesting (RegReal (RealRegPair{})) = panic "X86.interesting: no reg pairs on this arch" +interesting :: Platform -> Reg -> Bool +interesting _ (RegVirtual _) = True +interesting platform (RegReal (RealRegSingle i)) = isFastTrue (freeReg platform i) +interesting _ (RegReal (RealRegPair{})) = panic "X86.interesting: no reg pairs on this arch" @@ -709,11 +710,10 @@ x86_mkRegRegMoveInstr x86_mkRegRegMoveInstr platform src dst = case targetClassOfReg platform src of -#if i386_TARGET_ARCH - RcInteger -> MOV II32 (OpReg src) (OpReg dst) -#else - RcInteger -> MOV II64 (OpReg src) (OpReg dst) -#endif + RcInteger -> case platformArch platform of + ArchX86 -> MOV II32 (OpReg src) (OpReg dst) + ArchX86_64 -> MOV II64 (OpReg src) (OpReg dst) + _ -> panic "x86_mkRegRegMoveInstr: Bad arch" RcDouble -> GMOV src dst RcDoubleSSE -> MOV FF64 (OpReg src) (OpReg dst) _ -> panic "X86.RegInfo.mkRegRegMoveInstr: no match" diff --git a/compiler/nativeGen/X86/Regs.hs b/compiler/nativeGen/X86/Regs.hs index a53c4fcbf7..16938a8f15 100644 --- a/compiler/nativeGen/X86/Regs.hs +++ b/compiler/nativeGen/X86/Regs.hs @@ -39,10 +39,6 @@ module X86.Regs ( ripRel, allFPArgRegs, - -- horror show - freeReg, - globalRegMaybe, - allocatableRegs ) @@ -51,19 +47,7 @@ where #include "nativeGen/NCG.h" #include "HsVersions.h" -#if i386_TARGET_ARCH == 0 && x86_64_TARGET_ARCH == 0 --- Compiling for some arch other than Intel so we choose x86-64 as default. -#undef arm_TARGET_ARCH -#undef powerpc_TARGET_ARCH -#undef powerpc64_TARGET_ARCH -#undef sparc_TARGET_ARCH - -#undef x86_64_TARGET_ARCH -#define x86_64_TARGET_ARCH 1 -#endif - -#include "../includes/stg/HaskellMachRegs.h" - +import CodeGen.Platform import Reg import RegClass @@ -416,10 +400,6 @@ xmm n = regSingle (firstxmm+n) --- horror show ----------------------------------------------------------------- -freeReg :: RegNo -> FastBool -globalRegMaybe :: GlobalReg -> Maybe RealReg - -- | these are the regs which we cannot assume stay alive over a C call. callClobberedRegs :: Platform -> [Reg] -- caller-saves registers @@ -457,203 +437,17 @@ instrClobberedRegs platform | target32Bit platform = [ eax, ecx, edx ] | otherwise = [ rax, rcx, rdx ] -#if i386_TARGET_ARCH -#define eax 0 -#define ebx 1 -#define ecx 2 -#define edx 3 -#define esi 4 -#define edi 5 -#define ebp 6 -#define esp 7 -#endif - -#if x86_64_TARGET_ARCH -#define rax 0 -#define rbx 1 -#define rcx 2 -#define rdx 3 -#define rsi 4 -#define rdi 5 -#define rbp 6 -#define rsp 7 -#define r8 8 -#define r9 9 -#define r10 10 -#define r11 11 -#define r12 12 -#define r13 13 -#define r14 14 -#define r15 15 -#endif - -#define fake0 16 -#define fake1 17 -#define fake2 18 -#define fake3 19 -#define fake4 20 -#define fake5 21 - -#define xmm0 24 -#define xmm1 25 -#define xmm2 26 -#define xmm3 27 -#define xmm4 28 -#define xmm5 29 -#define xmm6 30 -#define xmm7 31 -#define xmm8 32 -#define xmm9 33 -#define xmm10 34 -#define xmm11 35 -#define xmm12 36 -#define xmm13 37 -#define xmm14 38 -#define xmm15 39 - -#if i386_TARGET_ARCH -freeReg esp = fastBool False -- %esp is the C stack pointer -#endif - -#if i386_TARGET_ARCH -freeReg esi = fastBool False -- Note [esi/edi not allocatable] -freeReg edi = fastBool False -#endif - -#if x86_64_TARGET_ARCH -freeReg rsp = fastBool False -- %rsp is the C stack pointer -#endif - --- split patterns in two functions to prevent overlaps -freeReg r = freeRegBase r - -freeRegBase :: RegNo -> FastBool - -#ifdef REG_Base -freeRegBase REG_Base = fastBool False -#endif -#ifdef REG_Sp -freeRegBase REG_Sp = fastBool False -#endif -#ifdef REG_SpLim -freeRegBase REG_SpLim = fastBool False -#endif -#ifdef REG_Hp -freeRegBase REG_Hp = fastBool False -#endif -#ifdef REG_HpLim -freeRegBase REG_HpLim = fastBool False -#endif - --- All other regs are considered to be "free", because we can track --- their liveness accurately. -freeRegBase _ = fastBool True - --- | Returns 'Nothing' if this global register is not stored --- in a real machine register, otherwise returns @'Just' reg@, where --- reg is the machine register it is stored in. - -#ifdef REG_Base -globalRegMaybe BaseReg = Just (RealRegSingle REG_Base) -#endif -#ifdef REG_R1 -globalRegMaybe (VanillaReg 1 _) = Just (RealRegSingle REG_R1) -#endif -#ifdef REG_R2 -globalRegMaybe (VanillaReg 2 _) = Just (RealRegSingle REG_R2) -#endif -#ifdef REG_R3 -globalRegMaybe (VanillaReg 3 _) = Just (RealRegSingle REG_R3) -#endif -#ifdef REG_R4 -globalRegMaybe (VanillaReg 4 _) = Just (RealRegSingle REG_R4) -#endif -#ifdef REG_R5 -globalRegMaybe (VanillaReg 5 _) = Just (RealRegSingle REG_R5) -#endif -#ifdef REG_R6 -globalRegMaybe (VanillaReg 6 _) = Just (RealRegSingle REG_R6) -#endif -#ifdef REG_R7 -globalRegMaybe (VanillaReg 7 _) = Just (RealRegSingle REG_R7) -#endif -#ifdef REG_R8 -globalRegMaybe (VanillaReg 8 _) = Just (RealRegSingle REG_R8) -#endif -#ifdef REG_R9 -globalRegMaybe (VanillaReg 9 _) = Just (RealRegSingle REG_R9) -#endif -#ifdef REG_R10 -globalRegMaybe (VanillaReg 10 _) = Just (RealRegSingle REG_R10) -#endif -#ifdef REG_F1 -globalRegMaybe (FloatReg 1) = Just (RealRegSingle REG_F1) -#endif -#ifdef REG_F2 -globalRegMaybe (FloatReg 2) = Just (RealRegSingle REG_F2) -#endif -#ifdef REG_F3 -globalRegMaybe (FloatReg 3) = Just (RealRegSingle REG_F3) -#endif -#ifdef REG_F4 -globalRegMaybe (FloatReg 4) = Just (RealRegSingle REG_F4) -#endif -#ifdef REG_D1 -globalRegMaybe (DoubleReg 1) = Just (RealRegSingle REG_D1) -#endif -#ifdef REG_D2 -globalRegMaybe (DoubleReg 2) = Just (RealRegSingle REG_D2) -#endif -#ifdef REG_Sp -globalRegMaybe Sp = Just (RealRegSingle REG_Sp) -#endif -#ifdef REG_Lng1 -globalRegMaybe (LongReg 1) = Just (RealRegSingle REG_Lng1) -#endif -#ifdef REG_Lng2 -globalRegMaybe (LongReg 2) = Just (RealRegSingle REG_Lng2) -#endif -#ifdef REG_SpLim -globalRegMaybe SpLim = Just (RealRegSingle REG_SpLim) -#endif -#ifdef REG_Hp -globalRegMaybe Hp = Just (RealRegSingle REG_Hp) -#endif -#ifdef REG_HpLim -globalRegMaybe HpLim = Just (RealRegSingle REG_HpLim) -#endif -#ifdef REG_CurrentTSO -globalRegMaybe CurrentTSO = Just (RealRegSingle REG_CurrentTSO) -#endif -#ifdef REG_CurrentNursery -globalRegMaybe CurrentNursery = Just (RealRegSingle REG_CurrentNursery) -#endif -globalRegMaybe _ = Nothing - -- -- All machine registers that are used for argument-passing to Haskell functions -allHaskellArgRegs :: [Reg] -allHaskellArgRegs = [ RegReal r | Just r <- map globalRegMaybe globalArgRegs ] +allHaskellArgRegs :: Platform -> [Reg] +allHaskellArgRegs platform = [ RegReal r | Just r <- map (globalRegMaybe platform) globalArgRegs ] -- allocatableRegs is allMachRegNos with the fixed-use regs removed. -- i.e., these are the regs for which we are prepared to allow the -- register allocator to attempt to map VRegs to. allocatableRegs :: Platform -> [RealReg] allocatableRegs platform - = let isFree i = isFastTrue (freeReg i) + = let isFree i = isFastTrue (freeReg platform i) in map RealRegSingle $ filter isFree (allMachRegNos platform) -{- -Note [esi/edi not allocatable] - -%esi is mapped to R1, so %esi would normally be allocatable while it -is not being used for R1. However, %esi has no 8-bit version on x86, -and the linear register allocator is not sophisticated enough to -handle this irregularity (we need more RegClasses). The -graph-colouring allocator also cannot handle this - it was designed -with more flexibility in mind, but the current implementation is -restricted to the same set of classes as the linear allocator. - -Hence, on x86 esi and edi are treated as not allocatable. --} diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.lhs index 9d12946052..87171545f8 100644 --- a/compiler/utils/Util.lhs +++ b/compiler/utils/Util.lhs @@ -10,7 +10,7 @@ module Util ( -- * Flags dependent on the compiler build ghciSupported, debugIsOn, ncgDebugIsOn, ghciTablesNextToCode, isDynamicGhcLib, - isWindowsHost, isWindowsTarget, isDarwinTarget, + isWindowsHost, isDarwinHost, -- * General list processing zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal, @@ -192,18 +192,11 @@ isWindowsHost = True isWindowsHost = False #endif -isWindowsTarget :: Bool -#ifdef mingw32_TARGET_OS -isWindowsTarget = True +isDarwinHost :: Bool +#ifdef darwin_HOST_OS +isDarwinHost = True #else -isWindowsTarget = False -#endif - -isDarwinTarget :: Bool -#ifdef darwin_TARGET_OS -isDarwinTarget = True -#else -isDarwinTarget = False +isDarwinHost = False #endif \end{code} |