diff --git a/RootInterpreted.ML b/RootInterpreted.ML index 653e6d89..46fc1480 100644 --- a/RootInterpreted.ML +++ b/RootInterpreted.ML @@ -1,131 +1,131 @@ (* Copyright (c) 2009, 2010, 2015-17, 2020 David C. J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) (* Compiler root file. This gives the "use" instructions necessary to build the compiler and suitable for use with an IDE project file. It was constructed from the Poly/ML make files. *) PolyML.print_depth 1; PolyML.Compiler.reportUnreferencedIds := true; use "mlsource/MLCompiler/Address.ML"; use "mlsource/MLCompiler/Misc.ML"; use "mlsource/MLCompiler/HashTable.ML"; use "mlsource/MLCompiler/UniversalTable.ML"; use "mlsource/MLCompiler/StronglyConnected.sml"; use "mlsource/MLCompiler/StretchArray.ML"; use "mlsource/MLCompiler/STRUCTVALSIG.sml"; use "mlsource/MLCompiler/PRETTYSIG.sml"; use "mlsource/MLCompiler/LEXSIG.sml"; use "mlsource/MLCompiler/SymbolsSig.sml"; use "mlsource/MLCompiler/COMPILERBODYSIG.sml"; -use "mlsource/MLCompiler/DEBUGSIG.ML"; +use "mlsource/MLCompiler/DEBUG.sig"; use "mlsource/MLCompiler/MAKESIG.sml"; use "mlsource/MLCompiler/MAKE_.ML"; use "mlsource/MLCompiler/FOREIGNCALLSIG.sml"; use "mlsource/MLCompiler/BUILTINS.sml"; use "mlsource/MLCompiler/CODETREESIG.ML"; use "mlsource/MLCompiler/STRUCT_VALS.ML"; use "mlsource/MLCompiler/CodeTree/BackendIntermediateCodeSig.sml"; use "mlsource/MLCompiler/CodeTree/BaseCodeTreeSig.sml"; use "mlsource/MLCompiler/CodeTree/CodetreeFunctionsSig.sml"; use "mlsource/MLCompiler/CodeTree/CODEARRAYSIG.ML"; use "mlsource/MLCompiler/CodeTree/CodegenTreeSig.sml"; use "mlsource/MLCompiler/CodeTree/GENCODESIG.sml"; use "mlsource/MLCompiler/CodeTree/CODETREE_FUNCTIONS.sml"; use "mlsource/MLCompiler/CodeTree/CODETREE_STATIC_LINK_AND_CASES.sml"; use "mlsource/MLCompiler/CodeTree/CODETREE_CODEGEN_CONSTANT_FUNCTIONS.sml"; use "mlsource/MLCompiler/CodeTree/CODETREE_LAMBDA_LIFT.sml"; use "mlsource/MLCompiler/CodeTree/CODETREE_REMOVE_REDUNDANT.sml"; use "mlsource/MLCompiler/CodeTree/CODETREE_SIMPLIFIER.sml"; use "mlsource/MLCompiler/CodeTree/CODETREE_OPTIMISER.sml"; use "mlsource/MLCompiler/CodeTree/CODETREE.ML"; use "mlsource/MLCompiler/Pretty.sml"; use "mlsource/MLCompiler/CodeTree/CODE_ARRAY.ML"; use "mlsource/MLCompiler/CodeTree/ByteCode/INTCODECONSSIG.sml"; use "mlsource/MLCompiler/CodeTree/ByteCode/INTCODECONS.ML"; use "mlsource/MLCompiler/CodeTree/ByteCode/INTGCODE.ML"; use "mlsource/MLCompiler/Debug.ML"; use "mlsource/MLCompiler/CodeTree/BackendIntermediateCode.sml"; use "mlsource/MLCompiler/CodeTree/BaseCodeTree.sml"; use "mlsource/MLCompiler/CodeTree/ByteCode/ml_bind.ML"; use "mlsource/MLCompiler/CodeTree/GCode.interpreted.ML"; use "mlsource/MLCompiler/CodeTree/ml_bind.ML"; use "mlsource/MLCompiler/StructVals.ML"; use "mlsource/MLCompiler/LEX_.ML"; use "mlsource/MLCompiler/Symbols.ML"; use "mlsource/MLCompiler/Lex.ML"; use "mlsource/MLCompiler/SymsetSig.sml"; use "mlsource/MLCompiler/DATATYPEREPSIG.sml"; use "mlsource/MLCompiler/VALUEOPSSIG.sml"; use "mlsource/MLCompiler/EXPORTTREESIG.sml"; use "mlsource/MLCompiler/STRUCTURESSIG.sml"; use "mlsource/MLCompiler/COMPILER_BODY.ML"; use "mlsource/MLCompiler/SymSet.ML"; use "mlsource/MLCompiler/TYPETREESIG.sml"; use "mlsource/MLCompiler/COPIERSIG.sml"; use "mlsource/MLCompiler/TYPEIDCODESIG.sml"; use "mlsource/MLCompiler/DATATYPE_REP.ML"; use "mlsource/MLCompiler/PRINTTABLESIG.sml"; use "mlsource/MLCompiler/VALUE_OPS.ML"; use "mlsource/MLCompiler/TYPE_TREE.ML"; use "mlsource/MLCompiler/UTILITIES_.ML"; use "mlsource/MLCompiler/Utilities.ML"; use "mlsource/MLCompiler/PRINT_TABLE.ML"; use "mlsource/MLCompiler/PrintTable.ML"; use "mlsource/MLCompiler/ExportTree.sml"; use "mlsource/MLCompiler/ExportTreeStruct.sml"; use "mlsource/MLCompiler/TypeTree.ML"; use "mlsource/MLCompiler/COPIER.sml"; use "mlsource/MLCompiler/CopierStruct.sml"; use "mlsource/MLCompiler/TYPEIDCODE.sml"; use "mlsource/MLCompiler/TypeIDCodeStruct.sml"; use "mlsource/MLCompiler/DatatypeRep.ML"; use "mlsource/MLCompiler/ValueOps.ML"; use "mlsource/MLCompiler/PARSETREESIG.sml"; use "mlsource/MLCompiler/SIGNATURESSIG.sml"; use "mlsource/MLCompiler/DEBUGGER.sig"; use "mlsource/MLCompiler/STRUCTURES_.ML"; use "mlsource/MLCompiler/DEBUGGER_.sml"; use "mlsource/MLCompiler/Debugger.sml"; use "mlsource/MLCompiler/ParseTree/BaseParseTreeSig.sml"; use "mlsource/MLCompiler/ParseTree/BASE_PARSE_TREE.sml"; use "mlsource/MLCompiler/ParseTree/PrintParsetreeSig.sml"; use "mlsource/MLCompiler/ParseTree/PRINT_PARSETREE.sml"; use "mlsource/MLCompiler/ParseTree/ExportParsetreeSig.sml"; use "mlsource/MLCompiler/ParseTree/EXPORT_PARSETREE.sml"; use "mlsource/MLCompiler/ParseTree/TypeCheckParsetreeSig.sml"; use "mlsource/MLCompiler/ParseTree/TYPECHECK_PARSETREE.sml"; use "mlsource/MLCompiler/ParseTree/MatchCompilerSig.sml"; use "mlsource/MLCompiler/ParseTree/MATCH_COMPILER.sml"; use "mlsource/MLCompiler/ParseTree/CodegenParsetreeSig.sml"; use "mlsource/MLCompiler/ParseTree/CODEGEN_PARSETREE.sml"; use "mlsource/MLCompiler/ParseTree/PARSE_TREE.ML"; use "mlsource/MLCompiler/ParseTree/ml_bind.ML"; use "mlsource/MLCompiler/SIGNATURES.sml"; use "mlsource/MLCompiler/SignaturesStruct.sml"; use "mlsource/MLCompiler/Structures.ML"; use "mlsource/MLCompiler/PARSE_DEC.ML"; use "mlsource/MLCompiler/SKIPS_.ML"; use "mlsource/MLCompiler/Skips.ML"; use "mlsource/MLCompiler/PARSE_TYPE.ML"; use "mlsource/MLCompiler/ParseType.ML"; use "mlsource/MLCompiler/ParseDec.ML"; use "mlsource/MLCompiler/CompilerBody.ML"; use "mlsource/MLCompiler/CompilerVersion.sml"; use "mlsource/MLCompiler/Make.ML"; use "mlsource/MLCompiler/INITIALISE_.ML"; use "mlsource/MLCompiler/Initialise.ML"; use "mlsource/MLCompiler/ml_bind.ML"; diff --git a/RootX86.ML b/RootX86.ML index ec80cd18..6648f961 100644 --- a/RootX86.ML +++ b/RootX86.ML @@ -1,151 +1,151 @@ (* Copyright (c) 2009, 2010, 2015-17, 2020 David C. J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) (* Compiler root file. This gives the "use" instructions necessary to build the compiler and suitable for use with an IDE project file. It was constructed from the Poly/ML make files. *) PolyML.print_depth 1; PolyML.Compiler.reportUnreferencedIds := true; use "mlsource/MLCompiler/Address.ML"; use "mlsource/MLCompiler/Misc.ML"; use "mlsource/MLCompiler/HashTable.ML"; use "mlsource/MLCompiler/UniversalTable.ML"; use "mlsource/MLCompiler/StronglyConnected.sml"; use "mlsource/MLCompiler/StretchArray.ML"; use "mlsource/MLCompiler/STRUCTVALSIG.sml"; use "mlsource/MLCompiler/PRETTYSIG.sml"; use "mlsource/MLCompiler/LEXSIG.sml"; use "mlsource/MLCompiler/SymbolsSig.sml"; use "mlsource/MLCompiler/COMPILERBODYSIG.sml"; -use "mlsource/MLCompiler/DEBUGSIG.ML"; +use "mlsource/MLCompiler/DEBUG.sig"; use "mlsource/MLCompiler/MAKESIG.sml"; use "mlsource/MLCompiler/MAKE_.ML"; use "mlsource/MLCompiler/FOREIGNCALLSIG.sml"; use "mlsource/MLCompiler/BUILTINS.sml"; use "mlsource/MLCompiler/CODETREESIG.ML"; use "mlsource/MLCompiler/STRUCT_VALS.ML"; use "mlsource/MLCompiler/CodeTree/BackendIntermediateCodeSig.sml"; use "mlsource/MLCompiler/CodeTree/BaseCodeTreeSig.sml"; use "mlsource/MLCompiler/CodeTree/CodetreeFunctionsSig.sml"; use "mlsource/MLCompiler/CodeTree/CODEARRAYSIG.ML"; use "mlsource/MLCompiler/CodeTree/CodegenTreeSig.sml"; use "mlsource/MLCompiler/CodeTree/GENCODESIG.sml"; use "mlsource/MLCompiler/CodeTree/CODETREE_FUNCTIONS.sml"; use "mlsource/MLCompiler/CodeTree/CODETREE_STATIC_LINK_AND_CASES.sml"; use "mlsource/MLCompiler/CodeTree/CODETREE_CODEGEN_CONSTANT_FUNCTIONS.sml"; use "mlsource/MLCompiler/CodeTree/CODETREE_LAMBDA_LIFT.sml"; use "mlsource/MLCompiler/CodeTree/CODETREE_REMOVE_REDUNDANT.sml"; use "mlsource/MLCompiler/CodeTree/CODETREE_SIMPLIFIER.sml"; use "mlsource/MLCompiler/CodeTree/CODETREE_OPTIMISER.sml"; use "mlsource/MLCompiler/CodeTree/CODETREE.ML"; use "mlsource/MLCompiler/Pretty.sml"; use "mlsource/MLCompiler/CodeTree/CODE_ARRAY.ML"; use "mlsource/MLCompiler/CodeTree/X86Code/X86CODESIG.sml"; use "mlsource/MLCompiler/CodeTree/X86Code/ICodeSig.ML"; use "mlsource/MLCompiler/CodeTree/X86Code/X86ICODEGENERATESIG.ML"; use "mlsource/MLCompiler/CodeTree/X86Code/X86ALLOCATEREGISTERSSIG.ML"; use "mlsource/MLCompiler/CodeTree/X86Code/X86ICODETRANSFORMSIG.ML"; use "mlsource/MLCompiler/CodeTree/X86Code/X86IDENTIFYREFSSIG.ML"; use "mlsource/MLCompiler/CodeTree/X86Code/X86GETCONFLICTSETSIG.ML"; use "mlsource/MLCompiler/CodeTree/X86Code/X86PUSHREGISTERSIG.ML"; use "mlsource/MLCompiler/CodeTree/X86Code/INTSETSIG.sml"; use "mlsource/MLCompiler/CodeTree/X86Code/X86ICODEOPTSIG.ML"; use "mlsource/MLCompiler/CodeTree/X86Code/IntSet.sml"; use "mlsource/MLCompiler/CodeTree/X86Code/X86ICode.ML"; use "mlsource/MLCompiler/CodeTree/X86Code/X86ICodeToX86Code.ML"; use "mlsource/MLCompiler/CodeTree/X86Code/X86AllocateRegisters.ML"; use "mlsource/MLCompiler/CodeTree/X86Code/X86ICodeOptimise.ML"; use "mlsource/MLCompiler/CodeTree/X86Code/X86ICodeTransform.ML"; use "mlsource/MLCompiler/CodeTree/X86Code/X86ICodeIdentifyReferences.ML"; use "mlsource/MLCompiler/CodeTree/X86Code/X86ICodeGetConflictSets.ML"; use "mlsource/MLCompiler/CodeTree/X86Code/X86PushRegisters.ML"; use "mlsource/MLCompiler/CodeTree/X86Code/X86CodetreeToICode.ML"; use "mlsource/MLCompiler/CodeTree/X86Code/X86OUTPUTCODE.ML"; use "mlsource/MLCompiler/CodeTree/X86Code/X86OPTIMISE.ML"; use "mlsource/MLCompiler/Debug.ML"; use "mlsource/MLCompiler/CodeTree/X86Code/X86FOREIGNCALL.sml"; use "mlsource/MLCompiler/CodeTree/BackendIntermediateCode.sml"; use "mlsource/MLCompiler/CodeTree/BaseCodeTree.sml"; use "mlsource/MLCompiler/CodeTree/X86Code/ml_bind.ML"; use "mlsource/MLCompiler/CodeTree/GCode.i386.ML"; use "mlsource/MLCompiler/CodeTree/ml_bind.ML"; use "mlsource/MLCompiler/StructVals.ML"; use "mlsource/MLCompiler/LEX_.ML"; use "mlsource/MLCompiler/Symbols.ML"; use "mlsource/MLCompiler/Lex.ML"; use "mlsource/MLCompiler/SymsetSig.sml"; use "mlsource/MLCompiler/DATATYPEREPSIG.sml"; use "mlsource/MLCompiler/VALUEOPSSIG.sml"; use "mlsource/MLCompiler/EXPORTTREESIG.sml"; use "mlsource/MLCompiler/STRUCTURESSIG.sml"; use "mlsource/MLCompiler/COMPILER_BODY.ML"; use "mlsource/MLCompiler/SymSet.ML"; use "mlsource/MLCompiler/TYPETREESIG.sml"; use "mlsource/MLCompiler/COPIERSIG.sml"; use "mlsource/MLCompiler/TYPEIDCODESIG.sml"; use "mlsource/MLCompiler/DATATYPE_REP.ML"; use "mlsource/MLCompiler/PRINTTABLESIG.sml"; use "mlsource/MLCompiler/VALUE_OPS.ML"; use "mlsource/MLCompiler/TYPE_TREE.ML"; use "mlsource/MLCompiler/UTILITIES_.ML"; use "mlsource/MLCompiler/Utilities.ML"; use "mlsource/MLCompiler/PRINT_TABLE.ML"; use "mlsource/MLCompiler/PrintTable.ML"; use "mlsource/MLCompiler/ExportTree.sml"; use "mlsource/MLCompiler/ExportTreeStruct.sml"; use "mlsource/MLCompiler/TypeTree.ML"; use "mlsource/MLCompiler/COPIER.sml"; use "mlsource/MLCompiler/CopierStruct.sml"; use "mlsource/MLCompiler/TYPEIDCODE.sml"; use "mlsource/MLCompiler/TypeIDCodeStruct.sml"; use "mlsource/MLCompiler/DatatypeRep.ML"; use "mlsource/MLCompiler/ValueOps.ML"; use "mlsource/MLCompiler/PARSETREESIG.sml"; use "mlsource/MLCompiler/SIGNATURESSIG.sml"; use "mlsource/MLCompiler/DEBUGGER.sig"; use "mlsource/MLCompiler/STRUCTURES_.ML"; use "mlsource/MLCompiler/DEBUGGER_.sml"; use "mlsource/MLCompiler/Debugger.sml"; use "mlsource/MLCompiler/ParseTree/BaseParseTreeSig.sml"; use "mlsource/MLCompiler/ParseTree/BASE_PARSE_TREE.sml"; use "mlsource/MLCompiler/ParseTree/PrintParsetreeSig.sml"; use "mlsource/MLCompiler/ParseTree/PRINT_PARSETREE.sml"; use "mlsource/MLCompiler/ParseTree/ExportParsetreeSig.sml"; use "mlsource/MLCompiler/ParseTree/EXPORT_PARSETREE.sml"; use "mlsource/MLCompiler/ParseTree/TypeCheckParsetreeSig.sml"; use "mlsource/MLCompiler/ParseTree/TYPECHECK_PARSETREE.sml"; use "mlsource/MLCompiler/ParseTree/MatchCompilerSig.sml"; use "mlsource/MLCompiler/ParseTree/MATCH_COMPILER.sml"; use "mlsource/MLCompiler/ParseTree/CodegenParsetreeSig.sml"; use "mlsource/MLCompiler/ParseTree/CODEGEN_PARSETREE.sml"; use "mlsource/MLCompiler/ParseTree/PARSE_TREE.ML"; use "mlsource/MLCompiler/ParseTree/ml_bind.ML"; use "mlsource/MLCompiler/SIGNATURES.sml"; use "mlsource/MLCompiler/SignaturesStruct.sml"; use "mlsource/MLCompiler/Structures.ML"; use "mlsource/MLCompiler/PARSE_DEC.ML"; use "mlsource/MLCompiler/SKIPS_.ML"; use "mlsource/MLCompiler/Skips.ML"; use "mlsource/MLCompiler/PARSE_TYPE.ML"; use "mlsource/MLCompiler/ParseType.ML"; use "mlsource/MLCompiler/ParseDec.ML"; use "mlsource/MLCompiler/CompilerBody.ML"; use "mlsource/MLCompiler/CompilerVersion.sml"; use "mlsource/MLCompiler/Make.ML"; use "mlsource/MLCompiler/INITIALISE_.ML"; use "mlsource/MLCompiler/Initialise.ML"; use "mlsource/MLCompiler/ml_bind.ML"; diff --git a/mlsource/MLCompiler/COMPILER_BODY.ML b/mlsource/MLCompiler/COMPILER_BODY.ML index 6f83ae42..9f19b795 100644 --- a/mlsource/MLCompiler/COMPILER_BODY.ML +++ b/mlsource/MLCompiler/COMPILER_BODY.ML @@ -1,270 +1,270 @@ (* Copyright (c) 2000 Cambridge University Technical Services Limited - Modified David C.J. Matthews 2008, 2015. + Modified David C.J. Matthews 2008, 2015, 2020. This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) (* Title: Body of ML Compiler. Author: Dave Matthews, Cambridge University Computer Laboratory Copyright Cambridge University 1985 *) functor COMPILER_BODY ( structure SYMSET : sig type sys type symset val inside: sys * symset -> bool; val ++ : symset * symset -> symset val abortParse: symset val semicolon: symset end; structure LEX : LEXSIG structure CODETREE : CODETREESIG structure STRUCTVALS : STRUCTVALSIG; structure VALUEOPS : VALUEOPSSIG; structure EXPORTTREE: EXPORTTREESIG structure STRUCTURES : STRUCTURESSIG structure PARSEDEC : sig type lexan type symset type fixStatus type program val parseDec: symset * lexan * { enterFix: string * fixStatus -> unit, lookupFix: string -> fixStatus option } -> program end; -structure DEBUG: DEBUGSIG +structure DEBUG: DEBUG structure UTILITIES : sig val searchList: unit -> { apply: (string * 'a -> unit) -> unit, enter: string * 'a -> unit, lookup: string -> 'a option} end; structure PRETTY : PRETTYSIG structure MISC : sig exception InternalError of string val lookupDefault : ('a -> 'b option) -> ('a -> 'b option) -> 'a -> 'b option val quickSort : ('a -> 'a -> bool) -> 'a list -> 'a list end; sharing STRUCTVALS.Sharing = VALUEOPS.Sharing = PRETTY.Sharing = STRUCTURES.Sharing = LEX.Sharing = EXPORTTREE.Sharing = SYMSET = PARSEDEC = CODETREE ) : COMPILERBODYSIG = (*****************************************************************************) (* COMPILERBODY functor body *) (*****************************************************************************) struct open MISC; open STRUCTVALS; open PRETTY; open LEX; open STRUCTURES open EXPORTTREE type nameSpace = { lookupVal: string -> values option, lookupType: string -> typeConstrSet option, lookupFix: string -> fixStatus option, lookupStruct: string -> structVals option, lookupSig: string -> signatures option, lookupFunct: string -> functors option, enterVal: string * values -> unit, enterType: string * typeConstrSet -> unit, enterFix: string * fixStatus -> unit, enterStruct: string * structVals -> unit, enterSig: string * signatures -> unit, enterFunct: string * functors -> unit, allVal: unit -> (string*values) list, allType: unit -> (string*typeConstrSet) list, allFix: unit -> (string*fixStatus) list, allStruct: unit -> (string*structVals) list, allSig: unit -> (string*signatures) list, allFunct: unit -> (string*functors) list } val stopSyms = let open SYMSET in op ++ (abortParse, semicolon) end fun baseCompiler (lex : lexan, nameSpace: nameSpace, debugSwitches) : exportTree option * (unit -> { fixes: (string * fixStatus) list, values: (string * values) list, structures: (string * structVals) list, signatures: (string * signatures) list, functors: (string * functors) list, types: (string * typeConstrSet) list }) option = let (* let1 *) val compilerOutput = getCompilerOutput debugSwitches val printParsetree = DEBUG.getParameter DEBUG.parsetreeTag debugSwitches val globals = { lookupFix = #lookupFix nameSpace, lookupVal = #lookupVal nameSpace, lookupType = #lookupType nameSpace, lookupSig = #lookupSig nameSpace, lookupStruct = #lookupStruct nameSpace, lookupFunct = #lookupFunct nameSpace, enterFix = #enterFix nameSpace, enterVal = #enterVal nameSpace, enterType = #enterType nameSpace, enterStruct = #enterStruct nameSpace, enterSig = #enterSig nameSpace, enterFunct = #enterFunct nameSpace, allValNames = fn () => map #1 (#allVal nameSpace ()) } val startLocn = location lex val () = if SYMSET.inside (sy lex, SYMSET.semicolon) then insymbol lex else () val parentTreeNav = case List.find (Universal.tagIs rootTreeTag) debugSwitches of SOME opt => Universal.tagProject rootTreeTag opt | NONE => { parent = NONE, next = NONE, previous = NONE } in (* An empty declaration (or end of file!) *) if SYMSET.inside (sy lex, stopSyms) then if errorOccurred lex (* We could have, for example, an unterminated comment. *) then (NONE, NONE) else (SOME(locSpan(startLocn, location lex), []), SOME (fn () => { fixes=[], values=[], structures=[], functors=[], types=[], signatures=[] }) ) (* Do nothing *) else let (* create a "throw away" compiling environment for this topdec *) val newFixEnv = UTILITIES.searchList () val enterFix = #enter newFixEnv val lookupFix = lookupDefault (#lookup newFixEnv) (#lookupFix globals) (* parse a program: a sequence of topdecs ending with a semicolon. *) val parseTree : STRUCTURES.program = PARSEDEC.parseDec (stopSyms, lex, {enterFix = enterFix, lookupFix = lookupFix}) val () = if printParsetree then compilerOutput (STRUCTURES.displayProgram (parseTree, 10000)) else () in if errorOccurred lex then (NONE, NONE) (* Error: No result and the parse tree won't be useful. *) else let (* If no errors then do second pass to match identifiers and declarations and return type of expression. *) val () = STRUCTURES.pass2Structs (parseTree, lex, Env globals) in if errorOccurred lex then (SOME(structsExportTree(parentTreeNav, parseTree)), NONE) else let (* Only code-generate if there were no errors and it's not a directive. *) val (structCode, nLocals) = STRUCTURES.gencodeStructs (parseTree, lex) in if errorOccurred lex then (* Errors can be produced during the code-generation phase. *) (SOME(structsExportTree(parentTreeNav, parseTree)), NONE) (* Error: No result. *) else let val resultCode = CODETREE.genCode(structCode, debugSwitches, nLocals) (* This is the function that is returned as the result of the compilation. *) fun executeCode() = STRUCTURES.pass4Structs (resultCode (), parseTree) in (SOME(structsExportTree (parentTreeNav, parseTree)), SOME executeCode) end end end end end fun compiler (nameSpace: nameSpace, getChar: unit->char option, parameters: Universal.universal list) : exportTree option * (unit -> { fixes: (string * fixStatus) list, values: (string * values) list, structures: (string * structVals) list, signatures: (string * signatures) list, functors: (string * functors) list, types: (string * typeConstrSet) list }) option = let val debugSwitches = parameters val lex = LEX.initial(getChar, debugSwitches) val compilerOutput = getCompilerOutput parameters fun printReport s = compilerOutput(PrettyString s) in baseCompiler(lex, nameSpace, debugSwitches) handle SML90.Interrupt => ( printReport "Compilation interrupted\n"; raise SML90.Interrupt ) | InternalError s => let val s' = "Exception- InternalError: " ^ String.toString s ^ " raised while compiling" in printReport (s' ^ "\n"); raise Fail s' end | exn => let val s' = "Exception- " ^ General.exnName exn ^ " unexpectedly raised while compiling" in printReport (s' ^ "\n"); raise Fail s' end end structure Sharing = struct type values = values and typeConstrSet = typeConstrSet and fixStatus = fixStatus and structVals = structVals and signatures = signatures and functors = functors and ptProperties = ptProperties end end; (* struct *) diff --git a/mlsource/MLCompiler/CodeTree/ByteCode/INTCODECONS.ML b/mlsource/MLCompiler/CodeTree/ByteCode/INTCODECONS.ML index fdbc0507..1faf78a9 100644 --- a/mlsource/MLCompiler/CodeTree/ByteCode/INTCODECONS.ML +++ b/mlsource/MLCompiler/CodeTree/ByteCode/INTCODECONS.ML @@ -1,1714 +1,1714 @@ (* Copyright (c) 2015-18, 2020 David C.J. Matthews Copyright (c) 2000 Cambridge University Technical Services Limited This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) functor INTCODECONS ( -structure DEBUG: DEBUGSIG +structure DEBUG: DEBUG structure PRETTY: PRETTYSIG ) : INTCODECONSSIG = struct open CODE_ARRAY open DEBUG open Address open Misc infix 5 << <<+ <<- >> >>+ >>- ~>> ~>>+ ~>>- (* Shift operators *) infix 3 andb orb xorb andbL orbL xorbL andb8 orb8 xorb8 val op << = Word.<< and op >> = Word.>> and op ~>> = Word.~>> val wordToWord8 = Word8.fromLargeWord o Word.toLargeWord and word8ToWord = Word.fromLargeWord o Word8.toLargeWord (* Typically the compiler is built on a little-endian machine but it could be run on a machine with either endian-ness. We have to find out the endian-ness when we run. There are separate versions of the compiler for 32-bit and 64-bit so that can be a constant. *) local val isBigEndian: unit -> bool = RunCall.rtsCallFast1 "PolyIsBigEndian" in val isBigEndian = isBigEndian() end val opcode_jump = 0wx02 (* 8-bit unsigned jump forward. *) and opcode_jumpFalse = 0wx03 (* Test top of stack. Take 8-bit unsigned jump if false. *) and opcode_loadMLWord = 0wx04 and opcode_storeMLWord = 0wx05 and opcode_alloc_ref = 0wx06 and opcode_blockMoveWord = 0wx07 and opcode_loadUntagged = 0wx08 and opcode_storeUntagged = 0wx09 and opcode_case16 = 0wx0a and opcode_callClosure = 0wx0c and opcode_returnW = 0wx0d and opcode_containerB = 0wx0e and opcode_raiseEx = 0wx10 and opcode_callConstAddr16 = 0wx11 and opcode_callConstAddr8 = 0wx12 and opcode_localW = 0wx13 and opcode_callLocalB = 0wx16 and opcode_constAddr16 = 0wx1a and opcode_constIntW = 0wx1b and opcode_jumpBack8 = 0wx1e (* 8-bit unsigned jump backwards - relative to end of instr. *) and opcode_returnB = 0wx1f and opcode_jumpBack16 = 0wx20 (* 16-bit unsigned jump backwards - relative to end of instr. *) and opcode_indirectLocalBB = 0wx21 and opcode_localB = 0wx22 and opcode_indirectB = 0wx23 and opcode_moveToContainerB = 0wx24 and opcode_setStackValB = 0wx25 and opcode_resetB = 0wx26 and opcode_resetRB = 0wx27 and opcode_constIntB = 0wx28 and opcode_local_0 = 0wx29 and opcode_local_1 = 0wx2a and opcode_local_2 = 0wx2b and opcode_local_3 = 0wx2c and opcode_local_4 = 0wx2d and opcode_local_5 = 0wx2e and opcode_local_6 = 0wx2f and opcode_local_7 = 0wx30 and opcode_local_8 = 0wx31 and opcode_local_9 = 0wx32 and opcode_local_10 = 0wx33 and opcode_local_11 = 0wx34 and opcode_indirect_0 = 0wx35 and opcode_indirect_1 = 0wx36 and opcode_indirect_2 = 0wx37 and opcode_indirect_3 = 0wx38 and opcode_indirect_4 = 0wx39 and opcode_indirect_5 = 0wx3a and opcode_const_0 = 0wx3b and opcode_const_1 = 0wx3c and opcode_const_2 = 0wx3d and opcode_const_3 = 0wx3e and opcode_const_4 = 0wx3f and opcode_const_10 = 0wx40 and opcode_return_1 = 0wx42 and opcode_return_2 = 0wx43 and opcode_return_3 = 0wx44 and opcode_local_12 = 0wx45 and opcode_jumpTrue = 0wx46 and opcode_jump16True = 0wx47 and opcode_local_13 = 0wx49 and opcode_local_14 = 0wx4a and opcode_local_15 = 0wx4b and opcode_reset_1 = 0wx50 and opcode_reset_2 = 0wx51 and opcode_indirectClosureBB = 0wx54 and opcode_resetR_1 = 0wx64 and opcode_resetR_2 = 0wx65 and opcode_resetR_3 = 0wx66 and opcode_tupleB = 0wx68 and opcode_tuple_2 = 0wx69 and opcode_tuple_3 = 0wx6a and opcode_tuple_4 = 0wx6b and opcode_lock = 0wx6c and opcode_ldexc = 0wx6d and opcode_indirectContainerB= 0wx74 and opcode_moveToMutClosureB = 0wx75 and opcode_allocMutClosureB = 0wx76 and opcode_indirectClosureB0 = 0wx77 and opcode_pushHandler = 0wx78 and opcode_indirectClosureB1 = 0wx7a and opcode_tailbb = 0wx7b and opcode_indirectClosureB2 = 0wx7c and opcode_setHandler = 0wx81 and opcode_callFastRTS0 = 0wx83 and opcode_callFastRTS1 = 0wx84 and opcode_callFastRTS2 = 0wx85 and opcode_callFastRTS3 = 0wx86 and opcode_callFastRTS4 = 0wx87 and opcode_callFastRTS5 = 0wx88 (*and opcode_callFullRTS0 = 0wx89 (* Legacy *) and opcode_callFullRTS1 = 0wx8a and opcode_callFullRTS2 = 0wx8b and opcode_callFullRTS3 = 0wx8c and opcode_callFullRTS4 = 0wx8d and opcode_callFullRTS5 = 0wx8e*) and opcode_notBoolean = 0wx91 and opcode_isTagged = 0wx92 and opcode_cellLength = 0wx93 and opcode_cellFlags = 0wx94 and opcode_clearMutable = 0wx95 and opcode_atomicIncr = 0wx97 and opcode_atomicDecr = 0wx98 and opcode_equalWord = 0wxa0 and opcode_lessSigned = 0wxa2 and opcode_lessUnsigned = 0wxa3 and opcode_lessEqSigned = 0wxa4 and opcode_lessEqUnsigned = 0wxa5 and opcode_greaterSigned = 0wxa6 and opcode_greaterUnsigned = 0wxa7 and opcode_greaterEqSigned = 0wxa8 and opcode_greaterEqUnsigned = 0wxa9 and opcode_fixedAdd = 0wxaa and opcode_fixedSub = 0wxab and opcode_fixedMult = 0wxac and opcode_fixedQuot = 0wxad and opcode_fixedRem = 0wxae and opcode_wordAdd = 0wxb1 and opcode_wordSub = 0wxb2 and opcode_wordMult = 0wxb3 and opcode_wordDiv = 0wxb4 and opcode_wordMod = 0wxb5 and opcode_wordAnd = 0wxb7 and opcode_wordOr = 0wxb8 and opcode_wordXor = 0wxb9 and opcode_wordShiftLeft = 0wxba and opcode_wordShiftRLog = 0wxbb and opcode_allocByteMem = 0wxbd and opcode_indirectLocalB1 = 0wxc1 and opcode_isTaggedLocalB = 0wxc2 and opcode_jumpNEqLocalInd = 0wxc3 and opcode_jumpTaggedLocal = 0wxc4 and opcode_jumpNEqLocal = 0wxc5 and opcode_indirect0Local0 = 0wxc6 and opcode_indirectLocalB0 = 0wxc7 and opcode_getThreadId = 0wxd9 and opcode_allocWordMemory = 0wxda and opcode_loadMLByte = 0wxdc and opcode_storeMLByte = 0wxe4 and opcode_blockMoveByte = 0wxec and opcode_blockEqualByte = 0wxed and opcode_blockCompareByte = 0wxee and opcode_deleteHandler = 0wxf1 (* Just deletes the handler - no jump. *) and opcode_jump16 = 0wxf7 and opcode_jump16False = 0wxf8 and opcode_setHandler16 = 0wxf9 and opcode_constAddr8 = 0wxfa (*and opcode_stackSize8 = 0wxfb*) and opcode_stackSize16 = 0wxfc and opcode_escape = 0wxfe (* For two-byte opcodes. *) (*and opcode_enterIntX86 = 0wxff*) (* Reserved - this is the first byte of a call *) (* Extended opcodes - preceded by 0xfe escape *) val ext_opcode_containerW = 0wx0b and ext_opcode_allocMutClosureW = 0wx0f (* Allocate a mutable closure for mutual recursion *) and ext_opcode_indirectClosureW = 0wx10 and ext_opcode_indirectContainerW= 0wx11 and ext_opcode_indirectW = 0wx14 and ext_opcode_moveToContainerW = 0wx15 and ext_opcode_moveToMutClosureW = 0wx16 and ext_opcode_setStackValW = 0wx17 and ext_opcode_resetW = 0wx18 and ext_opcode_resetR_w = 0wx19 and ext_opcode_callFastRTSRRtoR = 0wx1c and ext_opcode_callFastRTSRGtoR = 0wx1d and ext_opcode_jump32True = 0wx48 and ext_opcode_floatAbs = 0wx56 and ext_opcode_floatNeg = 0wx57 and ext_opcode_fixedIntToFloat = 0wx58 and ext_opcode_floatToReal = 0wx59 and ext_opcode_realToFloat = 0wx5a and ext_opcode_floatEqual = 0wx5b and ext_opcode_floatLess = 0wx5c and ext_opcode_floatLessEq = 0wx5d and ext_opcode_floatGreater = 0wx5e and ext_opcode_floatGreaterEq = 0wx5f and ext_opcode_floatAdd = 0wx60 and ext_opcode_floatSub = 0wx61 and ext_opcode_floatMult = 0wx62 and ext_opcode_floatDiv = 0wx63 and ext_opcode_tupleW = 0wx67 and ext_opcode_realToInt = 0wx6e and ext_opcode_floatToInt = 0wx6f and ext_opcode_callFastRTSFtoF = 0wx70 and ext_opcode_callFastRTSGtoF = 0wx71 and ext_opcode_callFastRTSFFtoF = 0wx72 and ext_opcode_callFastRTSFGtoF = 0wx73 and ext_opcode_realUnordered = 0wx79 and ext_opcode_floatUnordered = 0wx7a and ext_opcode_tail = 0wx7c and ext_opcode_callFastRTSRtoR = 0wx8f and ext_opcode_callFastRTSGtoR = 0wx90 and ext_opcode_atomicReset = 0wx99 and ext_opcode_longWToTagged = 0wx9a and ext_opcode_signedToLongW = 0wx9b and ext_opcode_unsignedToLongW = 0wx9c and ext_opcode_realAbs = 0wx9d and ext_opcode_realNeg = 0wx9e and ext_opcode_fixedIntToReal = 0wx9f and ext_opcode_fixedDiv = 0wxaf and ext_opcode_fixedMod = 0wxb0 and ext_opcode_wordShiftRArith = 0wxbc and ext_opcode_lgWordEqual = 0wxbe and ext_opcode_lgWordLess = 0wxc0 and ext_opcode_lgWordLessEq = 0wxc1 and ext_opcode_lgWordGreater = 0wxc2 and ext_opcode_lgWordGreaterEq = 0wxc3 and ext_opcode_lgWordAdd = 0wxc4 and ext_opcode_lgWordSub = 0wxc5 and ext_opcode_lgWordMult = 0wxc6 and ext_opcode_lgWordDiv = 0wxc7 and ext_opcode_lgWordMod = 0wxc8 and ext_opcode_lgWordAnd = 0wxc9 and ext_opcode_lgWordOr = 0wxca and ext_opcode_lgWordXor = 0wxcb and ext_opcode_lgWordShiftLeft = 0wxcc and ext_opcode_lgWordShiftRLog = 0wxcd and ext_opcode_lgWordShiftRArith = 0wxce and ext_opcode_realEqual = 0wxcf and ext_opcode_realLess = 0wxd1 and ext_opcode_realLessEq = 0wxd2 and ext_opcode_realGreater = 0wxd3 and ext_opcode_realGreaterEq = 0wxd4 and ext_opcode_realAdd = 0wxd5 and ext_opcode_realSub = 0wxd6 and ext_opcode_realMult = 0wxd7 and ext_opcode_realDiv = 0wxd8 and ext_opcode_loadC8 = 0wxdd and ext_opcode_loadC16 = 0wxde and ext_opcode_loadC32 = 0wxdf and ext_opcode_loadC64 = 0wxe0 and ext_opcode_loadCFloat = 0wxe1 and ext_opcode_loadCDouble = 0wxe2 and ext_opcode_storeC8 = 0wxe5 and ext_opcode_storeC16 = 0wxe6 and ext_opcode_storeC32 = 0wxe7 and ext_opcode_storeC64 = 0wxe8 and ext_opcode_storeCFloat = 0wxe9 and ext_opcode_storeCDouble = 0wxea and ext_opcode_jump32 = 0wxf2 (* 32-bit signed jump, forwards or backwards. *) and ext_opcode_jump32False = 0wxf3 (* Test top item. Take 32-bit signed jump if false. *) and ext_opcode_constAddr32 = 0wxf4 (* Followed by a 32-bit offset. Load a constant at that address. *) and ext_opcode_setHandler32 = 0wxf5 (* Setup a handler whose address is given by the 32-bit signed offset. *) and ext_opcode_case32 = 0wxf6 (* Indexed case with 32-bit offsets *) and ext_opcode_allocCSpace = 0wxfd and ext_opcode_freeCSpace = 0wxfe (* A Label is a ref that is later set to the location. Several labels can be linked together so that they are only set at a single point. Only forward jumps are linked so when we come to finally set the label we will have the full list. *) type labels = Word.word ref list ref (* Used for jump, jumpFalse, setHandler and delHandler. *) datatype jumpTypes = Jump | JumpBack | JumpFalse | JumpTrue | SetHandler datatype opcode = SimpleCode of Word8.word list (* Bytes that don't need any special treatment *) | LabelCode of labels (* A label - forwards or backwards. *) | JumpInstruction of { label: labels, jumpType: jumpTypes, size: jumpSize ref } (* Jumps or SetHandler. *) | PushConstant of { constNum: int, size : jumpSize ref, isCall: bool } | PushShort of Word.word | IndexedCase of { labels: labels list, size : jumpSize ref } | LoadLocal of Word8.word (* Locals - simplifies peephole optimisation. *) | IndirectLocal of { localAddr: Word8.word, indirect: Word8.word } (* Ditto *) | UncondTransfer of Word8.word list (* Raisex, return and tail. *) | IsTaggedLocalB of Word8.word | JumpOnIsTaggedLocalB of { label: labels, size: jumpSize ref, localAddr: Word8.word } | JumpNotEqualLocalInd0BB of { label: labels, size: jumpSize ref, localAddr: Word8.word, const: Word8.word } | JumpNotEqualLocalConstBB of { label: labels, size: jumpSize ref, localAddr: Word8.word, const: Word8.word } and jumpSize = Size8 | Size16 | Size32 and code = Code of { constVec: machineWord list ref, (* Vector of words to be put at end *) procName: string, (* Name of the procedure. *) printAssemblyCode:bool, (* Whether to print the code when we finish. *) printStream: string->unit, (* The stream to use *) stage1Code: opcode list ref } (* create and initialise a code segment *) fun codeCreate (name : string, parameters) = let val printStream = PRETTY.getSimplePrinter(parameters, []); in Code { constVec = ref [], procName = name, printAssemblyCode = DEBUG.getParameter DEBUG.assemblyCodeTag parameters, printStream = printStream, stage1Code = ref [] } end (* Find the offset in the constant area of a constant. *) (* The first has offset 0. *) fun addConstToVec (valu, Code{constVec, ...}) = let (* Search the list to see if the constant is already there. *) fun findConst valu [] num = (* Add to the list *) ( constVec := ! constVec @ [valu]; num ) | findConst valu (h :: t) num = if wordEq (valu, h) then num else findConst valu t (num + 1) (* Not equal *) in findConst valu (! constVec) 0 end fun printCode (seg: codeVec, procName: string, endcode, printStream) = let val () = printStream "\n"; val () = if procName = "" (* No name *) then printStream "?" else printStream procName; val () = printStream ":\n"; (* prints a string representation of a number *) fun printHex (v) = printStream(Word.fmt StringCvt.HEX v); val ptr = ref 0w0; (* Gets "length" bytes from locations "addr", "addr"+1... Returns an unsigned number. *) fun getB (0, _, _) = 0w0 | getB (length, addr, seg) = (getB (length - 1, addr + 0w1, seg) << 0w8) + word8ToWord (codeVecGet (seg, addr)) (* Prints a relative address. *) fun printDisp (len, spacer: string) = let val ad = getB(len, !ptr, seg) + !ptr + Word.fromInt len val () = printStream spacer; val () = printHex ad; in ptr := !ptr + Word.fromInt len end (* Prints an operand of an instruction *) fun printOp (len, spacer : string) = let val () = printStream spacer; val () = printHex (getB (len, !ptr, seg)) in ptr := !ptr + Word.fromInt len end; in while !ptr < endcode do let val addr = !ptr in printHex addr; (* The address. *) let (* It's an instruction. *) val () = printStream "\t" val opc = codeVecGet (seg, !ptr) (* opcode *) val () = ptr := !ptr + 0w1 in case opc of 0wx02 => (printStream "jump"; printDisp (1, "\t\t")) | 0wx03 => (printStream "jumpFalse"; printDisp (1, "\t")) | 0wx04 => printStream "loadMLWord" | 0wx05 => printStream "storeMLWord" | 0wx06 => printStream "alloc_ref" | 0wx07 => printStream "blockMoveWord" | 0wx08 => printStream "loadUntagged" | 0wx09 => printStream "storeUntagged" | 0wx0a => let (* Have to find out how many items there are. *) val limit = getB (2, !ptr, seg); val () = printOp (2, "case16\t"); val base = !ptr; fun printEntry _ = (printStream "\n\t"; printHex(base + getB(2, !ptr, seg)); ptr := !ptr + 0w2) fun forLoop f i n = if i >= n then () else (f i; forLoop f (i + 0w1) n) in forLoop printEntry 0w0 limit end | 0wx0c => printStream "callClosure" | 0wx0d => printOp(2, "returnW\t") | 0wx0e => printStream "containerB" | 0wx0f => printOp(2, "allocMutClosure") | 0wx10 => printStream "raiseEx" | 0wx11 => printDisp (2, "callConstAddr16\t") | 0wx12 => printDisp (1, "callConstAddr8\t") | 0wx13 => printOp(2, "localW\t") | 0wx16 => printOp(1, "callLocalB\t") | 0wx1a => (printStream "constAddr16"; printDisp (2, "\t")) | 0wx1b => printOp(2, "constIntW\t") | 0wx1e => ((* Should be negative *) printStream "jumpBack8\t"; printHex((!ptr - 0w1) - getB(1, !ptr, seg)); ptr := !ptr + 0w1 ) | 0wx1f => printOp(1, "returnB\t") | 0wx20 => ( printStream "jumpBack16\t"; printHex((!ptr - 0w1) - getB(2, !ptr, seg)); ptr := !ptr + 0w2 ) | 0wx21 => (printOp(1, "indirectLocalBB\t"); printOp(1, ",")) | 0wx22 => printOp(1, "localB\t") | 0wx23 => printOp(1, "indirectB\t") | 0wx24 => printOp(1, "moveToContainerB\t") | 0wx25 => printOp(1, "setStackValB\t") | 0wx26 => printOp(1, "resetB\t") | 0wx27 => printOp(1, "resetRB\t") | 0wx28 => printOp(1, "constIntB\t") | 0wx29 => printStream "local_0" | 0wx2a => printStream "local_1" | 0wx2b => printStream "local_2" | 0wx2c => printStream "local_3" | 0wx2d => printStream "local_4" | 0wx2e => printStream "local_5" | 0wx2f => printStream "local_6" | 0wx30 => printStream "local_7" | 0wx31 => printStream "local_8" | 0wx32 => printStream "local_9" | 0wx33 => printStream "local_10" | 0wx34 => printStream "local_11" | 0wx35 => printStream "indirect_0" | 0wx36 => printStream "indirect_1" | 0wx37 => printStream "indirect_2" | 0wx38 => printStream "indirect_3" | 0wx39 => printStream "indirect_4" | 0wx3a => printStream "indirect_5" | 0wx3b => printStream "const_0" | 0wx3c => printStream "const_1" | 0wx3d => printStream "const_2" | 0wx3e => printStream "const_3" | 0wx3f => printStream "const_4" | 0wx40 => printStream "const_10" | 0wx41 => printStream "return_0" | 0wx42 => printStream "return_1" | 0wx43 => printStream "return_2" | 0wx44 => printStream "return_3" | 0wx45 => printStream "local_12" | 0wx46 => (printStream "jumpTrue"; printDisp (1, "\t")) | 0wx47 => (printStream "jumpTrue"; printDisp (2, "\t")) | 0wx49 => printStream "local_13" | 0wx4a => printStream "local_14" | 0wx4b => printStream "local_15" | 0wx50 => printStream "reset_1" | 0wx51 => printStream "reset_2" | 0wx54 => (printOp(1, "indirectClosureBB\t"); printOp(1, ", ")) | 0wx64 => printStream "resetR_1" | 0wx65 => printStream "resetR_2" | 0wx66 => printStream "resetR_3" | 0wx68 => printOp(1, "tupleB\t") | 0wx69 => printStream "tuple_2" | 0wx6a => printStream "tuple_3" | 0wx6b => printStream "tuple_4" | 0wx6c => printStream "lock" | 0wx6d => printStream "ldexc" | 0wx74 => printOp(1, "indirectContainerB\t") | 0wx75 => printOp(1, "moveToMutClosureB\t") | 0wx76 => printOp(1, "allocMutClosureB\t") | 0wx77 => printOp(1, "indirectClosureB0\t") | 0wx78 => printStream "pushHandler" | 0wx7a => printOp(1, "indirectClosureB1\t") | 0wx7b => (printOp (1, "tailbb\t"); printOp (1, ",")) | 0wx7c => printOp(1, "indirectClosureB2\t") | 0wx7d => printOp(1, "tail3b\t") | 0wx7e => printOp(1, "tail4b\t") | 0wx7f => printStream "tail3_2" | 0wx80 => printStream "tail3_3" | 0wx81 => (printStream "setHandler"; printDisp (1, "\t")) | 0wx83 => printStream "callFastRTS0" | 0wx84 => printStream "callFastRTS1" | 0wx85 => printStream "callFastRTS2" | 0wx86 => printStream "callFastRTS3" | 0wx87 => printStream "callFastRTS4" | 0wx88 => printStream "callFastRTS5" | 0wx91 => printStream "notBoolean" | 0wx92 => printStream "isTagged" | 0wx93 => printStream "cellLength" | 0wx94 => printStream "cellFlags" | 0wx95 => printStream "clearMutable" | 0wx97 => printStream "atomicIncr" | 0wx98 => printStream "atomicDecr" | 0wxa0 => printStream "equalWord" | 0wxa1 => printOp(1, "equalWordConstB\t") | 0wxa2 => printStream "lessSigned" | 0wxa3 => printStream "lessUnsigned" | 0wxa4 => printStream "lessEqSigned" | 0wxa5 => printStream "lessEqUnsigned" | 0wxa6 => printStream "greaterSigned" | 0wxa7 => printStream "greaterUnsigned" | 0wxa8 => printStream "greaterEqSigned" | 0wxa9 => printStream "greaterEqUnsigned" | 0wxaa => printStream "fixedAdd" | 0wxab => printStream "fixedSub" | 0wxac => printStream "fixedMult" | 0wxad => printStream "fixedQuot" | 0wxae => printStream "fixedRem" | 0wxb1 => printStream "wordAdd" | 0wxb2 => printStream "wordSub" | 0wxb3 => printStream "wordMult" | 0wxb4 => printStream "wordDiv" | 0wxb5 => printStream "wordMod" | 0wxb7 => printStream "wordAnd" | 0wxb8 => printStream "wordOr" | 0wxb9 => printStream "wordXor" | 0wxba => printStream "wordShiftLeft" | 0wxbb => printStream "wordShiftRLog" | 0wxbd => printStream "allocByteMem" | 0wxc1 => printOp(1, "indirectLocalB1\t") | 0wxc2 => printOp(1, "isTaggedLocalB\t") | 0wxc3 => (printOp(1, "jumpNEqLocalInd\t"); printOp(1, ","); printOp(1, ","); printDisp(1, "\t")) | 0wxc4 => (printOp(1, "jumpTaggedLocal\t"); printDisp(1, "\t")) | 0wxc5 => (printOp(1, "jumpNEqLocal\t"); printOp(1, ","); printOp(1, ","); printDisp(1, "\t")) | 0wxc6 => printStream "indirect0Local0" | 0wxc7 => printOp(1, "indirectLocalB0\t") | 0wxd9 => printStream "getThreadId" | 0wxda => printStream "allocWordMemory" | 0wxdc => printStream "loadMLByte" | 0wxe4 => printStream "storeMLByte" | 0wxec => printStream "blockMoveByte" | 0wxed => printStream "blockEqualByte" | 0wxee => printStream "blockCompareByte" | 0wxf1 => printStream "deleteHandler" | 0wxf7 => printStream "jump16" | 0wxf8 => printStream "jump16False" | 0wxf9 => printStream "setHandler16" | 0wxfa => printDisp (1, "constAddr8\t") | 0wxfb => printOp(1, "stackSize8\t") | 0wxfc => printOp(2, "stackSize16\t") | 0wxff => printStream "enterIntX86" | 0wxfe => ( case codeVecGet (seg, !ptr) before ptr := !ptr + 0w1 of 0wx0b => printStream "containerW" | 0wx10 => printOp(2, "indirectClosureW\t") | 0wx11 => printOp(2, "indirectContainerW\t") | 0wx14 => printOp(2, "indirectW\t") | 0wx15 => printOp(2, "moveToContainerW\t") | 0wx16 => printOp(2, "moveToMutClosureW\t") | 0wx17 => printOp(2, "setStackValW\t") | 0wx18 => printOp(2, "resetW\t") | 0wx19 => printOp(2, "resetR_w\t") | 0wx1c => printStream "callFastRTSRRtoR" | 0wx1d => printStream "callFastRTSRGtoR" | 0wx48 => (printStream "jumpTrue"; printDisp (4, "\t")) | 0wx56 => printStream "floatAbs" | 0wx57 => printStream "floatNeg" | 0wx58 => printStream "fixedIntToFloat" | 0wx59 => printStream "floatToReal" | 0wx5a => printOp(1, "realToFloat\t") | 0wx5b => printStream "floatEqual" | 0wx5c => printStream "floatLess" | 0wx5d => printStream "floatLessEq" | 0wx5e => printStream "floatGreater" | 0wx5f => printStream "floatGreaterEq" | 0wx60 => printStream "floatAdd" | 0wx61 => printStream "floatSub" | 0wx62 => printStream "floatMult" | 0wx63 => printStream "floatDiv" | 0wx67 => printOp(2, "tupleW\t") | 0wx6e => printOp(1, "realToInt\t") | 0wx6f => printOp(1, "floatToInt\t") | 0wx70 => printStream "callFastRTSFtoF" | 0wx71 => printStream "callFastRTSGtoF" | 0wx72 => printStream "callFastRTSFFtoF" | 0wx73 => printStream "callFastRTSFGtoF" | 0wx79 => printStream "realUnordered" | 0wx7a => printStream "floatUnordered" | 0wx7c => (printOp (2, "tail\t"); printOp (2, ",")) | 0wx8f => printStream "callFastRTSRtoR" | 0wx90 => printStream "callFastRTSGtoR" | 0wx99 => printStream "atomicReset" | 0wx9a => printStream "longWToTagged" | 0wx9b => printStream "signedToLongW" | 0wx9c => printStream "unsignedToLongW" | 0wx9d => printStream "realAbs" | 0wx9e => printStream "realNeg" | 0wx9f => printStream "fixedIntToReal" | 0wxaf => printStream "fixedDiv" | 0wxb0 => printStream "fixedMod" | 0wxbc => printStream "wordShiftRArith" | 0wxbe => printStream "lgWordEqual" | 0wxc0 => printStream "lgWordLess" | 0wxc1 => printStream "lgWordLessEq" | 0wxc2 => printStream "lgWordGreater" | 0wxc3 => printStream "lgWordGreaterEq" | 0wxc4 => printStream "lgWordAdd" | 0wxc5 => printStream "lgWordSub" | 0wxc6 => printStream "lgWordMult" | 0wxc7 => printStream "lgWordDiv" | 0wxc8 => printStream "lgWordMod" | 0wxc9 => printStream "lgWordAnd" | 0wxca => printStream "lgWordOr" | 0wxcb => printStream "lgWordXor" | 0wxcc => printStream "lgWordShiftLeft" | 0wxcd => printStream "lgWordShiftRLog" | 0wxce => printStream "lgWordShiftRArith" | 0wxcf => printStream "realEqual" | 0wxd1 => printStream "realLess" | 0wxd2 => printStream "realLessEq" | 0wxd3 => printStream "realGreater" | 0wxd4 => printStream "realGreaterEq" | 0wxd5 => printStream "realAdd" | 0wxd6 => printStream "realSub" | 0wxd7 => printStream "realMult" | 0wxd8 => printStream "realDiv" | 0wxdd => printStream "loadC8" | 0wxde => printStream "loadC16" | 0wxdf => printStream "loadC32" | 0wxe0 => printStream "loadC64" | 0wxe1 => printStream "loadCFloat" | 0wxe2 => printStream "loadCDouble" | 0wxe5 => printStream "storeC8" | 0wxe6 => printStream "storeC16" | 0wxe7 => printStream "storeC32" | 0wxe8 => printStream "storeC64" | 0wxe9 => printStream "storeCFloat" | 0wxea => printStream "storeCDouble" | 0wxf2 => printDisp (4, "jump32\t") | 0wxf3 => printDisp (4, "jump32False\t") | 0wxf4 => printDisp (4, "constAddr32\t") | 0wxf5 => printDisp (4, "setHandler32\t") | 0wxf6 => let (* Have to find out how many items there are. *) val limit = getB (2, !ptr, seg); val () = printOp (2, "case32\t"); val base = !ptr; fun printEntry _ = (printStream "\n\t"; printHex(base + getB(4, !ptr, seg)); ptr := !ptr + 0w4) fun forLoop f i n = if i >= n then () else (f i; forLoop f (i + 0w1) n) in forLoop printEntry 0w0 limit end | 0wxfd => printStream "allocCSpace" | 0wxfe => printStream "freeCSpace" | _ => printStream ("unknown:0xfe 0x" ^ Word8.toString opc) ) | opc => printStream("unknown:0x" ^ Word8.toString opc) end; (* an instruction. *) printStream "\n" end (* main loop *) end (* printCode *) fun codeSize (SimpleCode l) = List.length l | codeSize (LabelCode _) = 0 | codeSize (JumpInstruction{size=ref Size8, ...}) = 2 | codeSize (JumpInstruction{size=ref Size16, ...}) = 3 | codeSize (JumpInstruction{size=ref Size32, ...}) = 6 | codeSize (PushConstant{size=ref Size8, ...}) = 2 | codeSize (PushConstant{size=ref Size16, ...}) = 3 | codeSize (PushConstant{size=ref Size32, isCall=false, ...}) = 6 | codeSize (PushConstant{size=ref Size32, isCall=true, ...}) = 7 | codeSize (PushShort value) = if value <= 0w4 orelse value = 0w10 then 1 else if value < 0w256 then 2 else 3 | codeSize (IndexedCase{labels, size=ref Size32, ...}) = 4 + List.length labels * 4 | codeSize (IndexedCase{labels, size=ref Size16, ...}) = 3 + List.length labels * 2 | codeSize (IndexedCase{labels=_, size=ref Size8, ...}) = raise InternalError "codeSize" | codeSize (LoadLocal w) = if w <= 0w15 then 1 else 2 | codeSize (IndirectLocal{indirect=0w0, localAddr=0w0}) = 1 | codeSize (IndirectLocal{indirect=0w0, ...}) = 2 | codeSize (IndirectLocal{indirect=0w1, ...}) = 2 | codeSize (IndirectLocal _) = 3 | codeSize (UncondTransfer l) = List.length l | codeSize (IsTaggedLocalB _) = 2 | codeSize (JumpOnIsTaggedLocalB{size=ref Size8, ...}) = 3 | codeSize (JumpOnIsTaggedLocalB{size=ref Size16, ...}) = 5 | codeSize (JumpOnIsTaggedLocalB{size=ref Size32, ...}) = 8 | codeSize (JumpNotEqualLocalInd0BB{size=ref Size8, ...}) = 4 | codeSize (JumpNotEqualLocalInd0BB{label, size, localAddr, const}) = codeSize(IndirectLocal{localAddr=localAddr, indirect=0w0}) + codeSize(PushShort(word8ToWord const)) + 1 + codeSize(JumpInstruction{jumpType=JumpFalse, label=label, size=size}) | codeSize (JumpNotEqualLocalConstBB{size=ref Size8, ...}) = 4 | codeSize (JumpNotEqualLocalConstBB {label, size, localAddr, const}) = codeSize(LoadLocal localAddr) + codeSize(PushShort(word8ToWord const)) + 1 + codeSize(JumpInstruction{jumpType=JumpFalse, label=label, size=size}) (* General function to process the code. ic is the byte counter within the original code. *) fun foldCode startIc foldFn ops = let fun doFold(oper :: operList, ic) = doFold(operList, (* Get the size BEFORE any possible change. *) ic + Word.fromInt(codeSize oper) before foldFn(oper, ic)) | doFold(_, ic) = ic in doFold(ops, startIc) end (* Process the code, setting the destination of any labels. Return the length of the code. *) fun setLabels(LabelCode(ref labs) :: ops, ic) = (List.app(fn d => d := ic) labs; setLabels(ops, ic)) | setLabels(oper :: ops, ic) = setLabels(ops, ic + Word.fromInt(codeSize oper)) | setLabels([], ic) = ic (* Set the sizes of branches depending on the distance to the destination. *) fun setLabelsAndSizes ops = let val wordLength = wordSize (* Set the labels and adjust the sizes, repeating until it never gets smaller*) fun setLabAndSize(ops, lastSize) = let (* Calculate offsets for constants. *) val endIC = Word.andb(lastSize + wordLength - 0w1, ~ wordLength) val firstConstant = endIC + wordLength * 0w3 (* Because the constant area is word aligned we have to allow for the possibility that the distance between a "load constant" instruction and the target could actually increase. *) val alignment = wordLength - 0w1 fun adjust(JumpInstruction{size as ref Size32, label=ref lab, ...}, ic) = let val dest = !(hd lab) val diff = if dest <= ic (* N.B. Include infinite loops as backwards. *) then ic - dest (* Backwards - Counts from start of instruction. *) else dest - (ic + 0w6) (* Forwards - Relative to the current end. *) in if diff < 0wx100 then size := Size8 else if diff < 0wx10000 then size := Size16 else () end | adjust(JumpInstruction{size as ref Size16, label=ref lab, ...}, ic) = let val dest = !(hd lab) in if dest <= ic then if ic - dest < 0wx100 then size := Size8 else () else if dest - (ic + 0w3) < 0wx100 then size := Size8 else () end | adjust(IndexedCase{size as ref Size32, labels}, ic) = let val startAddr = ic+0w4 (* Use 16-bit case if all the offsets are 16-bits. *) fun is16bit(ref lab) = let val dest = !(hd lab) in dest > startAddr andalso dest < startAddr+0wx10000 end in if List.all is16bit labels then size := Size16 else () end | adjust(PushConstant{size as ref Size32, constNum, ...}, ic) = let val constAddr = firstConstant + Word.fromInt constNum * wordLength val offset = constAddr - (ic + 0w6) in if offset < 0wx100-alignment then size := Size8 else if offset < 0wx10000-alignment then size := Size16 else () end | adjust(PushConstant{size as ref Size16, constNum, ...}, ic) = let val constAddr = firstConstant + Word.fromInt constNum * wordLength val offset = constAddr - (ic + 0w3) in if offset < 0wx100-alignment then size := Size8 else () end | adjust(JumpOnIsTaggedLocalB{size as ref Size32, label=ref lab, ...}, ic) = let val dest = !(hd lab) val diff = dest - (ic + 0w8) in if diff < 0wx100 then size := Size8 else if diff < 0wx10000 then size := Size16 else () end | adjust(JumpOnIsTaggedLocalB{size as ref Size16, label=ref lab, ...}, ic) = let val dest = !(hd lab) in if dest - (ic + 0w5) < 0wx100 then size := Size8 else () end | adjust(j as JumpNotEqualLocalInd0BB{size as ref Size32, label=ref lab, ...}, ic) = let val dest = !(hd lab) val diff = dest - (ic + Word.fromInt(codeSize j)) in if diff < 0wx100 then size := Size8 else if diff < 0wx10000 then size := Size16 else () end | adjust(j as JumpNotEqualLocalInd0BB{size as ref Size16, label=ref lab, ...}, ic) = let val dest = !(hd lab) in if dest - (ic + Word.fromInt(codeSize j)) < 0wx100 then size := Size8 else () end | adjust(j as JumpNotEqualLocalConstBB{size as ref Size32, label=ref lab, ...}, ic) = let val dest = !(hd lab) val diff = dest - (ic + Word.fromInt(codeSize j)) in if diff < 0wx100 then size := Size8 else if diff < 0wx10000 then size := Size16 else () end | adjust(j as JumpNotEqualLocalConstBB{size as ref Size16, label=ref lab, ...}, ic) = let val dest = !(hd lab) in if dest - (ic + Word.fromInt(codeSize j)) < 0wx100 then size := Size8 else () end | adjust _ = () val _ = foldCode 0w0 adjust ops val nextSize = setLabels(ops, 0w0) in if nextSize < lastSize then setLabAndSize(ops, nextSize) else if nextSize = lastSize then lastSize else raise InternalError "setLabAndSize - size increased" end in setLabAndSize(ops, setLabels(ops, 0w0)) end fun genCode(ops, Code {constVec, ...}) = let (* First pass - set the labels. *) val codeSize = setLabelsAndSizes ops val wordSize = wordSize (* Align to wordLength. *) val endIC = Word.andb(codeSize + wordSize - 0w1, ~ wordSize) val paddingBytes = List.tabulate(Word.toInt(endIC - codeSize), fn _ => SimpleCode[opcode_const_0]) val endOfCode = endIC div wordSize val firstConstant = endIC + wordSize * 0w3 (* Add 3 for fn name, unused and profile count. *) val segSize = endOfCode + Word.fromInt(List.length(! constVec)) + 0w4 val codeVec = byteVecMake segSize val ic = ref 0w0 fun genByte b = byteVecSet(codeVec, !ic, b) before ic := !ic + 0w1 fun genByteCode(SimpleCode bytes, _) = (* Simple code - just generate the bytes. *) List.app genByte bytes | genByteCode(UncondTransfer bytes, _) = List.app genByte bytes | genByteCode(LabelCode _, _) = () | genByteCode(JumpInstruction{label=ref labs, jumpType, size=ref Size32, ...}, ic) = let val dest = !(hd labs) val extOpc = case jumpType of SetHandler => ext_opcode_setHandler32 | JumpFalse => ext_opcode_jump32False | JumpTrue => ext_opcode_jump32True | Jump => ext_opcode_jump32 | JumpBack => ext_opcode_jump32 val diff = dest - (ic + 0w6) in genByte opcode_escape; genByte extOpc; genByte(wordToWord8 diff); (* This may be negative so we must use an arithmetic shift. *) genByte(wordToWord8(diff ~>> 0w8)); genByte(wordToWord8(diff ~>> 0w16)); genByte(wordToWord8(diff ~>> 0w24)) end | genByteCode(JumpInstruction{label=ref labs, jumpType, size=ref Size16, ...}, ic) = let val dest = !(hd labs) in if dest <= ic then (* Jump back. *) let val _ = jumpType = JumpBack orelse raise InternalError "genByteCode - back jump" val diff = ic - dest val _ = diff < 0wx10000 orelse raise InternalError "genByteCode - jump range" in genByte opcode_jumpBack16; genByte(wordToWord8 diff); genByte(wordToWord8(diff >> 0w8)) end else let val opc = case jumpType of SetHandler => opcode_setHandler16 | JumpFalse => opcode_jump16False | JumpTrue => opcode_jump16True | Jump => opcode_jump16 | JumpBack => raise InternalError "genByteCode: JumpBack goes forward" val diff = dest - (ic + 0w3) val _ = diff < 0wx10000 orelse raise InternalError "genByteCode - jump range" in genByte opc; genByte(wordToWord8 diff); genByte(wordToWord8(diff >> 0w8)) end end | genByteCode(JumpInstruction{label=ref labs, jumpType, size=ref Size8, ...}, ic) = let val dest = !(hd labs) in if dest <= ic then (* Jump back. *) let val _ = jumpType = JumpBack orelse raise InternalError "genByteCode - back jump" val diff = ic - dest val _ = diff < 0wx100 orelse raise InternalError "genByteCode - jump range" in genByte opcode_jumpBack8; genByte(wordToWord8 diff) end else let val opc = case jumpType of SetHandler => opcode_setHandler | JumpFalse => opcode_jumpFalse | JumpTrue => opcode_jumpTrue | Jump => opcode_jump | JumpBack => raise InternalError "genByteCode: JumpBack goes forward" val diff = dest - (ic + 0w2) val _ = diff < 0wx100 orelse raise InternalError "genByteCode - jump range" in genByte opc; genByte(wordToWord8 diff) end end | genByteCode(PushConstant{ constNum, size=ref Size32, isCall=false, ... }, ic) = let val constAddr = firstConstant + Word.fromInt constNum * wordSize (* Offsets are calculated from the END of the instruction *) val offset = constAddr - (ic + 0w6) in genByte opcode_escape; genByte ext_opcode_constAddr32; genByte(wordToWord8 offset); genByte(wordToWord8(offset >> 0w8)); genByte(wordToWord8(offset >> 0w16)); genByte(wordToWord8(offset >> 0w24)) end | genByteCode(PushConstant{ constNum, size=ref Size32, isCall=true, ... }, ic) = ( (* Turn this back into a push of a constant and call-closure. *) genByteCode(PushConstant{ constNum=constNum, size=ref Size32, isCall=false }, ic); genByte opcode_callClosure ) | genByteCode(PushConstant{ constNum, size=ref Size16, isCall, ... }, ic) = let val constAddr = firstConstant + Word.fromInt constNum * wordSize val offset = constAddr - (ic + 0w3) val _ = offset < 0wx10000 orelse raise InternalError "genByteCode - constant range" in genByte(if isCall then opcode_callConstAddr16 else opcode_constAddr16); genByte(wordToWord8 offset); genByte(wordToWord8(offset >> 0w8)) end | genByteCode(PushConstant{ constNum, size=ref Size8, isCall, ... }, ic) = let val constAddr = firstConstant + Word.fromInt constNum * wordSize val offset = constAddr - (ic + 0w2) val _ = offset < 0wx100 orelse raise InternalError "genByteCode - constant range" in genByte(if isCall then opcode_callConstAddr8 else opcode_constAddr8); genByte(wordToWord8 offset) end | genByteCode(PushShort 0w0, _) = genByte opcode_const_0 | genByteCode(PushShort 0w1, _) = genByte opcode_const_1 | genByteCode(PushShort 0w2, _) = genByte opcode_const_2 | genByteCode(PushShort 0w3, _) = genByte opcode_const_3 | genByteCode(PushShort 0w4, _) = genByte opcode_const_4 | genByteCode(PushShort 0w10, _) = genByte opcode_const_10 | genByteCode(PushShort value, _) = if value < 0w256 then (genByte opcode_constIntB; genByte(wordToWord8 value)) else (genByte opcode_constIntW; genByte(wordToWord8 value); genByte(wordToWord8(value >> 0w8))) | genByteCode(IndexedCase{labels, size=ref Size32, ...}, ic) = let val nCases = List.length labels val () = genByte opcode_escape val () = genByte ext_opcode_case32 val () = genByte(Word8.fromInt nCases) val () = genByte(Word8.fromInt (nCases div 256)) val startOffset = ic+0w4 (* Offsets are relative to here. *) fun putLabel(ref labs) = let val dest = !(hd labs) val diff = dest - startOffset val _ = dest > startOffset orelse raise InternalError "genByteCode - indexed case" in genByte(wordToWord8 diff); genByte(wordToWord8(diff >> 0w8)); genByte(wordToWord8(diff >> 0w16)); genByte(wordToWord8(diff >> 0w24)) end in List.app putLabel labels end | genByteCode(IndexedCase{labels, size=ref Size16, ...}, ic) = let val nCases = List.length labels val () = genByte(opcode_case16) val () = genByte(Word8.fromInt nCases) val () = genByte(Word8.fromInt (nCases div 256)) val startOffset = ic+0w3 (* Offsets are relative to here. *) fun putLabel(ref labs) = let val dest = !(hd labs) val diff = dest - startOffset val _ = dest > startOffset orelse raise InternalError "genByteCode - indexed case" val _ = diff < 0wx10000 orelse raise InternalError "genByteCode - indexed case" in genByte(wordToWord8 diff); genByte(wordToWord8(diff >> 0w8)) end in List.app putLabel labels end | genByteCode(IndexedCase{size=ref Size8, ...}, _) = raise InternalError "genByteCode - IndexedCase byte" | genByteCode(LoadLocal 0w0, _) = genByte opcode_local_0 | genByteCode(LoadLocal 0w1, _) = genByte opcode_local_1 | genByteCode(LoadLocal 0w2, _) = genByte opcode_local_2 | genByteCode(LoadLocal 0w3, _) = genByte opcode_local_3 | genByteCode(LoadLocal 0w4, _) = genByte opcode_local_4 | genByteCode(LoadLocal 0w5, _) = genByte opcode_local_5 | genByteCode(LoadLocal 0w6, _) = genByte opcode_local_6 | genByteCode(LoadLocal 0w7, _) = genByte opcode_local_7 | genByteCode(LoadLocal 0w8, _) = genByte opcode_local_8 | genByteCode(LoadLocal 0w9, _) = genByte opcode_local_9 | genByteCode(LoadLocal 0w10, _) = genByte opcode_local_10 | genByteCode(LoadLocal 0w11, _) = genByte opcode_local_11 | genByteCode(LoadLocal 0w12, _) = genByte opcode_local_12 | genByteCode(LoadLocal 0w13, _) = genByte opcode_local_13 | genByteCode(LoadLocal 0w14, _) = genByte opcode_local_14 | genByteCode(LoadLocal 0w15, _) = genByte opcode_local_15 | genByteCode(LoadLocal w, _) = (genByte opcode_localB; genByte w) | genByteCode(IndirectLocal{localAddr=0w0, indirect=0w0}, _) = genByte opcode_indirect0Local0 | genByteCode(IndirectLocal{localAddr, indirect=0w0}, _) = (genByte opcode_indirectLocalB0; genByte localAddr) | genByteCode(IndirectLocal{localAddr, indirect=0w1}, _) = (genByte opcode_indirectLocalB1; genByte localAddr) | genByteCode(IndirectLocal{localAddr, indirect}, _) = (genByte opcode_indirectLocalBB; genByte localAddr; genByte indirect) | genByteCode(IsTaggedLocalB addr, _) = (genByte opcode_isTaggedLocalB; genByte addr) | genByteCode(JumpOnIsTaggedLocalB {label=ref labs, size=ref Size8, localAddr}, ic) = let val dest = !(hd labs) val diff = dest - (ic + 0w3) in genByte opcode_jumpTaggedLocal; genByte localAddr; genByte(wordToWord8 diff) end | genByteCode(JumpOnIsTaggedLocalB {label, size, localAddr}, ic) = ( (* Turn this back into the original sequence. *) genByteCode(IsTaggedLocalB localAddr, ic); genByteCode(JumpInstruction{jumpType=JumpTrue, label=label, size=size}, ic+0w2) ) | genByteCode(JumpNotEqualLocalInd0BB {label=ref labs, size=ref Size8, localAddr, const}, ic) = let val dest = !(hd labs) val diff = dest - (ic + 0w4) in genByte opcode_jumpNEqLocalInd; genByte localAddr; genByte const; genByte(wordToWord8 diff) end | genByteCode(JumpNotEqualLocalInd0BB {label, size, localAddr, const}, ic) = (* Turn this back into the original sequence. *) (foldCode ic genByteCode [IndirectLocal{localAddr=localAddr, indirect=0w0}, PushShort(word8ToWord const), SimpleCode[opcode_equalWord], JumpInstruction{jumpType=JumpFalse, label=label, size=size}]; ()) | genByteCode(JumpNotEqualLocalConstBB {label=ref labs, size=ref Size8, localAddr, const}, ic) = let val dest = !(hd labs) val diff = dest - (ic + 0w4) in genByte opcode_jumpNEqLocal; genByte localAddr; genByte const; genByte(wordToWord8 diff) end | genByteCode(JumpNotEqualLocalConstBB {label, size, localAddr, const}, ic) = (* Turn this back into the original sequence. *) (foldCode ic genByteCode [LoadLocal localAddr, PushShort(word8ToWord const), SimpleCode[opcode_equalWord], JumpInstruction{jumpType=JumpFalse, label=label, size=size}]; ()) in foldCode 0w0 genByteCode (ops @ paddingBytes); (codeVec (* Return the completed code. *), endIC (* And the size. *)) end fun setLong (value, addrs, seg) = let val wordLength = wordSize fun putBytes(value, a, seg, i) = if i = wordLength then () else ( byteVecSet(seg, if not isBigEndian then a+i else a+wordLength-i-0w1, Word8.fromInt(value mod 256)); putBytes(value div 256, a, seg, i+0w1) ) in putBytes(value, addrs, seg, 0w0) end (* Peephole optimisation. *) local fun peepHole([], _, output) = List.rev output | peepHole(LabelCode lab1 :: (instrs as LabelCode lab2 :: _), exited, output) = ( (* Consecutive labels. Merge these, discarding the first. *) lab2 := !lab1 @ !lab2; peepHole(instrs, exited, output) ) (* A label followed by an unconditional branch. Forward the original label. Although JumpBack is also unconditional we don't forward those because we don't have a conditional backwards jump. *) | peepHole((LabelCode lab1) :: (jump as JumpInstruction{jumpType=Jump, label=lab2, ...}) :: tl, exited, output) = ( lab2 := !lab1 @ !lab2; (* Leave the jump in the stream and leave "exited" unchanged. This will now be unreachable if we had previously exited but we need to take the jump if we hadn't. *) peepHole(jump :: tl, exited, output) ) (* Discard everything after an unconditional transfer until the next label. *) | peepHole((label as LabelCode _) :: tl, _, output) = peepHole(tl, false, label::output) | peepHole(_ :: tl, true, output) = peepHole(tl, true, output) | peepHole((jump as JumpInstruction{jumpType=Jump, ...}) :: tl, _, output) = peepHole(tl, true, jump :: output) (* Return, raise-exception and tail-call. *) | peepHole((uncond as UncondTransfer _) :: tl, _, output) = peepHole(tl, true, uncond :: output) (* A conditional branch round an unconditional branch. Replace by a conditional branch with the sense reversed. *) | peepHole((cond as JumpInstruction{jumpType=JumpFalse, label=lab1, ...}) :: (uncond as JumpInstruction{jumpType=Jump, label=lab2, size}) :: (tail as LabelCode lab3 :: _), _, output) = if lab1 = lab3 then peepHole(tail, false, JumpInstruction{jumpType=JumpTrue, label=lab2, size=size} :: output) else peepHole(uncond :: tail, false, cond :: output) | peepHole((cond as JumpInstruction{jumpType=JumpTrue, label=lab1, ...}) :: (uncond as JumpInstruction{jumpType=Jump, label=lab2, size}) :: (tail as LabelCode lab3 :: _), _, output) = if lab1 = lab3 then peepHole(tail, false, JumpInstruction{jumpType=JumpFalse, label=lab2, size=size} :: output) else peepHole(uncond :: tail, false, cond :: output) | peepHole(IsTaggedLocalB addr :: JumpInstruction{jumpType=JumpTrue, label, size} :: tail, _, output) = peepHole(tail, false, JumpOnIsTaggedLocalB {label=label, size=size, localAddr=addr} :: output) | peepHole((indLocal as IndirectLocal{localAddr, indirect=0w0}) :: (instrs as PushShort const :: SimpleCode[0wxa0(*opcode_equalWord*)] :: JumpInstruction{jumpType=JumpFalse, label, size} :: tail), _, output) = if const < 0w256 then peepHole(tail, false, JumpNotEqualLocalInd0BB {label=label, size=size, localAddr=localAddr, const=wordToWord8 const} :: output) else peepHole(instrs, false, indLocal :: output) | peepHole((load as LoadLocal localAddr) :: (instrs as PushShort const :: SimpleCode[0wxa0(*opcode_equalWord*)] :: JumpInstruction{jumpType=JumpFalse, label, size} :: tail), _, output) = if const < 0w256 then peepHole(tail, false, JumpNotEqualLocalConstBB {label=label, size=size, localAddr=localAddr, const=wordToWord8 const} :: output) else peepHole(instrs, false, load :: output) | peepHole(hd::tl, exited, output) = peepHole(tl, exited, hd::output) in fun optimise code = peepHole(code, false, []) end (* Adds the constants onto the code, and copies the code into a new segment *) fun copyCode (cvec as Code{ printAssemblyCode, printStream, procName, constVec, stage1Code, ...}, maxStack, resultClosure) = let local val revCode = optimise(List.rev(!stage1Code)) (* Add a stack check. This is only needed if the function needs more than 128 words since the call and tail functions check for this much. *) in val codeList = if maxStack < 128 then revCode else SimpleCode[opcode_stackSize16, Word8.fromInt maxStack, Word8.fromInt(maxStack div 256)] :: revCode end val (byteVec, endIC) = genCode(codeList, cvec) val wordLength = wordSize (* +3 for profile count, function name and constants count *) val numOfConst = List.length(! constVec) val endOfCode = endIC div wordLength val segSize = endOfCode + Word.fromInt numOfConst + 0w4 val firstConstant = endIC + wordLength * 0w3 (* Add 3 for fn name, unused and profile count. *) (* Put in the number of constants. This must go in before we actually put in any constants. *) local val addr = ((segSize - 0w1) * wordLength) in val () = setLong (numOfConst + 3, addr, byteVec) end (* Now we've filled in all the size info we need to convert the segment into a proper code segment before it's safe to put in any ML values. *) val codeVec = byteVecToCodeVec(byteVec, resultClosure) local val name : string = procName val nameWord : machineWord = toMachineWord name in val () = codeVecPutWord (codeVec, endOfCode, nameWord) end (* This used to be used on X86 for the register mask. *) val () = codeVecPutWord (codeVec, endOfCode+0w1, toMachineWord 1) (* Profile ref. A byte ref used by the profiler in the RTS. *) local val v = RunCall.allocateByteMemory(0w1, Word.fromLargeWord(Word8.toLargeWord(Word8.orb(F_mutable, F_bytes)))) fun clear 0w0 = () | clear i = (assignByte(v, i-0w1, 0w0); clear (i-0w1)) val () = clear(wordSize) in val () = codeVecPutWord (codeVec, endOfCode+0w2, toMachineWord v) end (* and then copy the constants from the constant list. *) local fun setConstant(value, num) = let val constAddr = (firstConstant div wordLength) + num in codeVecPutWord (codeVec, constAddr, value); num+0w1 end in val _ = List.foldl setConstant 0w0 (!constVec) end in if printAssemblyCode then (* print out the code *) (printCode (codeVec, procName, endIC, printStream); printStream"\n") else (); codeVecLock(codeVec, resultClosure) end (* copyCode *) fun addItemToList(item, Code{stage1Code, ...}) = stage1Code := item :: !stage1Code val genOpcode = addItemToList fun putBranchInstruction(brOp, label, cvec) = addItemToList(JumpInstruction{label=label, jumpType=brOp, size = ref Size32}, cvec) fun setLabel(label, cvec) = addItemToList(LabelCode label, cvec) fun createLabel () = ref [ref 0w0] local fun genOpc(opc, cvec) = addItemToList(SimpleCode [opc], cvec) and genExtOpc(opc, cvec) = addItemToList(SimpleCode [opcode_escape, opc], cvec) and genOpcByte(opc, arg1, cvec) = if 0 <= arg1 andalso arg1 < 256 then addItemToList(SimpleCode [opc, Word8.fromInt arg1], cvec) else raise InternalError "genOpcByte" and genExtOpcByte(opc, arg1, cvec) = if 0 <= arg1 andalso arg1 < 256 then addItemToList(SimpleCode [opcode_escape, opc, Word8.fromInt arg1], cvec) else raise InternalError "genExtOpcByte" and genExtOpcWord(opc, arg1, cvec) = if 0 <= arg1 andalso arg1 < 65536 then addItemToList(SimpleCode[opcode_escape, opc, Word8.fromInt arg1, Word8.fromInt (arg1 div 256)], cvec) else raise InternalError "genExtOpcWord" open IEEEReal fun encodeRound TO_NEAREST = 0 | encodeRound TO_NEGINF = 1 | encodeRound TO_POSINF = 2 | encodeRound TO_ZERO = 3 in fun genRaiseEx cvec = addItemToList(UncondTransfer [opcode_raiseEx], cvec) fun genLock cvec = genOpc (opcode_lock, cvec) fun genLdexc cvec = genOpc (opcode_ldexc, cvec) fun genPushHandler cvec = genOpc (opcode_pushHandler, cvec) fun genRTSCallFast(0, cvec) = genOpc (opcode_callFastRTS0, cvec) | genRTSCallFast(1, cvec) = genOpc (opcode_callFastRTS1, cvec) | genRTSCallFast(2, cvec) = genOpc (opcode_callFastRTS2, cvec) | genRTSCallFast(3, cvec) = genOpc (opcode_callFastRTS3, cvec) | genRTSCallFast(4, cvec) = genOpc (opcode_callFastRTS4, cvec) | genRTSCallFast(5, cvec) = genOpc (opcode_callFastRTS5, cvec) | genRTSCallFast(_, _) = raise InternalError "genRTSFastCall" fun genContainer (size, cvec) = if size < 256 then genOpcByte(opcode_containerB, size, cvec) else genExtOpcWord(ext_opcode_containerW, size, cvec) fun genCase (nCases, cvec) = let val labels = List.tabulate(nCases, fn _ => createLabel()) in addItemToList(IndexedCase{labels=labels, size=ref Size32}, cvec); labels end (* For the moment don't try to merge stack resets. *) fun resetStack(0, _, _) = () | resetStack(1, true, cvec) = addItemToList(SimpleCode[opcode_resetR_1], cvec) | resetStack(2, true, cvec) = addItemToList(SimpleCode[opcode_resetR_2], cvec) | resetStack(3, true, cvec) = addItemToList(SimpleCode[opcode_resetR_3], cvec) | resetStack(offset, true, cvec) = if offset < 0 then raise InternalError "resetStack" else if offset > 255 then genExtOpcWord(ext_opcode_resetR_w, offset, cvec) else genOpcByte(opcode_resetRB, offset, cvec) | resetStack(1, false, cvec) = addItemToList(SimpleCode[opcode_reset_1], cvec) | resetStack(2, false, cvec) = addItemToList(SimpleCode[opcode_reset_2], cvec) | resetStack(offset, false, cvec) = if offset < 0 then raise InternalError "resetStack" else if offset > 255 then genExtOpcWord(ext_opcode_resetW, offset, cvec) else genOpcByte(opcode_resetB, offset, cvec) fun genCallClosure(Code{stage1Code as ref(PushConstant{constNum, size, isCall=false} :: tail), ...}) = stage1Code := PushConstant{constNum=constNum, size=size, isCall=true} :: tail | genCallClosure(Code{stage1Code as ref(LoadLocal w :: tail), ...}) = stage1Code := SimpleCode [opcode_callLocalB, w] :: tail | genCallClosure(Code{stage1Code, ...}) = stage1Code := SimpleCode [opcode_callClosure] :: !stage1Code fun genTailCall (toslide, slideby, cvec) = if toslide < 256 andalso slideby < 256 then (* General byte case *) addItemToList(UncondTransfer[opcode_tailbb, Word8.fromInt toslide, Word8.fromInt slideby], cvec) else (* General case. *) addItemToList( UncondTransfer[opcode_escape, ext_opcode_tail, Word8.fromInt toslide, Word8.fromInt(toslide div 256), Word8.fromInt slideby, Word8.fromInt (slideby div 256)], cvec) fun pushConst (value : machineWord, cvec) = if isShort value andalso toShort value < 0w32768 then addItemToList(PushShort(toShort value), cvec) else (* address or large short *) addItemToList(PushConstant{constNum = addConstToVec(value, cvec), size=ref Size32, isCall=false}, cvec) fun genRTSCallFastRealtoReal cvec = genExtOpc (ext_opcode_callFastRTSRtoR, cvec) and genRTSCallFastRealRealtoReal cvec = genExtOpc (ext_opcode_callFastRTSRRtoR, cvec) and genRTSCallFastGeneraltoReal cvec = genExtOpc (ext_opcode_callFastRTSGtoR, cvec) and genRTSCallFastRealGeneraltoReal cvec = genExtOpc (ext_opcode_callFastRTSRGtoR, cvec) and genRTSCallFastFloattoFloat cvec = genExtOpc (ext_opcode_callFastRTSFtoF, cvec) and genRTSCallFastFloatFloattoFloat cvec = genExtOpc (ext_opcode_callFastRTSFFtoF, cvec) and genRTSCallFastGeneraltoFloat cvec = genExtOpc (ext_opcode_callFastRTSGtoF, cvec) and genRTSCallFastFloatGeneraltoFloat cvec = genExtOpc (ext_opcode_callFastRTSFGtoF, cvec) fun genDoubleToFloat(SOME rnding, cvec) = genExtOpcByte(ext_opcode_realToFloat, encodeRound rnding, cvec) | genDoubleToFloat(NONE, cvec) = genExtOpcByte(ext_opcode_realToFloat, 5, cvec) and genRealToInt(rnding, cvec) = genExtOpcByte(ext_opcode_realToInt, encodeRound rnding, cvec) and genFloatToInt(rnding, cvec) = genExtOpcByte(ext_opcode_floatToInt, encodeRound rnding, cvec) fun genEqualWordConst(w, cvec) = (pushConst(toMachineWord w, cvec); genOpc(opcode_equalWord, cvec)) fun genIsTagged(Code{stage1Code as ref(LoadLocal addr :: tail), ...}) = stage1Code := IsTaggedLocalB addr :: tail | genIsTagged cvec = genOpc(opcode_isTagged, cvec) fun genIndirectSimple(0, cvec) = genOpc(opcode_indirect_0, cvec) | genIndirectSimple(1, cvec) = genOpc(opcode_indirect_1, cvec) | genIndirectSimple(2, cvec) = genOpc(opcode_indirect_2, cvec) | genIndirectSimple(3, cvec) = genOpc(opcode_indirect_3, cvec) | genIndirectSimple(4, cvec) = genOpc(opcode_indirect_4, cvec) | genIndirectSimple(5, cvec) = genOpc(opcode_indirect_5, cvec) | genIndirectSimple(arg1, cvec) = if arg1 < 256 then genOpcByte(opcode_indirectB, arg1, cvec) else genExtOpcWord(ext_opcode_indirectW, arg1, cvec) fun genIndirectContainer(arg1, cvec) = if arg1 < 256 then genOpcByte(opcode_indirectContainerB, arg1, cvec) else genExtOpcWord(ext_opcode_indirectContainerW, arg1, cvec) fun genMoveToContainer (arg1, cvec) = if arg1 < 256 then genOpcByte(opcode_moveToContainerB, arg1, cvec) else genExtOpcWord(ext_opcode_moveToContainerW, arg1, cvec) fun genMoveToMutClosure (arg1, cvec) = if arg1 < 256 then genOpcByte(opcode_moveToMutClosureB, arg1, cvec) else genExtOpcWord(ext_opcode_moveToMutClosureW, arg1, cvec) fun genSetStackVal (arg1, cvec) = if arg1 < 256 then genOpcByte(opcode_setStackValB, arg1, cvec) else genExtOpcWord(ext_opcode_setStackValW, arg1, cvec) fun genTuple (2, cvec) = genOpc(opcode_tuple_2, cvec) | genTuple (3, cvec) = genOpc(opcode_tuple_3, cvec) | genTuple (4, cvec) = genOpc(opcode_tuple_4, cvec) | genTuple (arg1, cvec) = if arg1 < 256 then genOpcByte(opcode_tupleB, arg1, cvec) else genExtOpcWord(ext_opcode_tupleW, arg1, cvec) fun genAllocMutableClosure(closureSize, cvec) = if closureSize < 256 then genOpcByte(opcode_allocMutClosureB, closureSize, cvec) else genExtOpcWord(ext_opcode_allocMutClosureW, closureSize, cvec) fun genLocal (arg1, cvec) = if 0 <= arg1 andalso arg1 < 256 then addItemToList(LoadLocal(Word8.fromInt arg1), cvec) else addItemToList(SimpleCode[opcode_localW, Word8.fromInt arg1, Word8.fromInt(arg1 div 256)], cvec) fun genIndirectClosure{ addr, item, code=cvec } = if addr < 256 andalso item < 256 then ( case item of 0 => genOpcByte(opcode_indirectClosureB0, addr, cvec) | 1 => genOpcByte(opcode_indirectClosureB1, addr, cvec) | 2 => genOpcByte(opcode_indirectClosureB2, addr, cvec) | _ => addItemToList(SimpleCode[opcode_indirectClosureBB, Word8.fromInt addr, Word8.fromInt item], cvec) ) else ( genLocal (addr, cvec); addItemToList(SimpleCode[opcode_escape, ext_opcode_indirectClosureW, Word8.fromInt item, Word8.fromInt (item div 256)], cvec) ) end fun genReturn(1, cvec) = addItemToList(UncondTransfer[opcode_return_1], cvec) | genReturn(2, cvec) = addItemToList(UncondTransfer[opcode_return_2], cvec) | genReturn(3, cvec) = addItemToList(UncondTransfer[opcode_return_3], cvec) | genReturn(arg1, cvec) = addItemToList(UncondTransfer( if 0 <= arg1 andalso arg1 <= 255 then [opcode_returnB, Word8.fromInt arg1] else [opcode_returnW, Word8.fromInt arg1, Word8.fromInt(arg1 div 256)]), cvec) fun genIndirect (arg1, cvec as Code{stage1Code as ref(LoadLocal w :: tail), ...}) = if 0 <= arg1 andalso arg1 <= 255 then stage1Code := IndirectLocal{localAddr=w, indirect=Word8.fromInt arg1} :: tail else genIndirectSimple(arg1, cvec) | genIndirect (arg1, cvec) = genIndirectSimple(arg1, cvec) fun genEnterIntCatch _ = () and genEnterIntCall _ = () val opcode_notBoolean = SimpleCode [opcode_notBoolean] val opcode_cellLength = SimpleCode [opcode_cellLength] and opcode_cellFlags = SimpleCode [opcode_cellFlags] and opcode_clearMutable = SimpleCode [opcode_clearMutable] and opcode_atomicIncr = SimpleCode [opcode_atomicIncr] and opcode_atomicDecr = SimpleCode [opcode_atomicDecr] and opcode_atomicReset = SimpleCode [opcode_escape, ext_opcode_atomicReset] and opcode_longWToTagged = SimpleCode [opcode_escape, ext_opcode_longWToTagged] and opcode_signedToLongW = SimpleCode [opcode_escape, ext_opcode_signedToLongW] and opcode_unsignedToLongW = SimpleCode [opcode_escape, ext_opcode_unsignedToLongW] and opcode_realAbs = SimpleCode [opcode_escape, ext_opcode_realAbs] and opcode_realNeg = SimpleCode [opcode_escape, ext_opcode_realNeg] and opcode_fixedIntToReal = SimpleCode [opcode_escape, ext_opcode_fixedIntToReal] and opcode_fixedIntToFloat = SimpleCode [opcode_escape, ext_opcode_fixedIntToFloat] and opcode_floatToReal = SimpleCode [opcode_escape, ext_opcode_floatToReal] val opcode_equalWord = SimpleCode [opcode_equalWord] and opcode_lessSigned = SimpleCode [opcode_lessSigned] and opcode_lessUnsigned = SimpleCode [opcode_lessUnsigned] and opcode_lessEqSigned = SimpleCode [opcode_lessEqSigned] and opcode_lessEqUnsigned = SimpleCode [opcode_lessEqUnsigned] and opcode_greaterSigned = SimpleCode [opcode_greaterSigned] and opcode_greaterUnsigned = SimpleCode [opcode_greaterUnsigned] and opcode_greaterEqSigned = SimpleCode [opcode_greaterEqSigned] and opcode_greaterEqUnsigned = SimpleCode [opcode_greaterEqUnsigned] val opcode_fixedAdd = SimpleCode [opcode_fixedAdd] val opcode_fixedSub = SimpleCode [opcode_fixedSub] val opcode_fixedMult = SimpleCode [opcode_fixedMult] val opcode_fixedQuot = SimpleCode [opcode_fixedQuot] val opcode_fixedRem = SimpleCode [opcode_fixedRem] val opcode_fixedDiv = SimpleCode [opcode_escape, ext_opcode_fixedDiv] val opcode_fixedMod = SimpleCode [opcode_escape, ext_opcode_fixedMod] val opcode_wordAdd = SimpleCode [opcode_wordAdd] val opcode_wordSub = SimpleCode [opcode_wordSub] val opcode_wordMult = SimpleCode [opcode_wordMult] val opcode_wordDiv = SimpleCode [opcode_wordDiv] val opcode_wordMod = SimpleCode [opcode_wordMod] val opcode_wordAnd = SimpleCode [opcode_wordAnd] val opcode_wordOr = SimpleCode [opcode_wordOr] val opcode_wordXor = SimpleCode [opcode_wordXor] val opcode_wordShiftLeft = SimpleCode [opcode_wordShiftLeft] val opcode_wordShiftRLog = SimpleCode [opcode_wordShiftRLog] val opcode_wordShiftRArith = SimpleCode [opcode_escape, ext_opcode_wordShiftRArith] val opcode_allocByteMem = SimpleCode [opcode_allocByteMem] val opcode_lgWordEqual = SimpleCode [opcode_escape, ext_opcode_lgWordEqual] val opcode_lgWordLess = SimpleCode [opcode_escape, ext_opcode_lgWordLess] val opcode_lgWordLessEq = SimpleCode [opcode_escape, ext_opcode_lgWordLessEq] val opcode_lgWordGreater = SimpleCode [opcode_escape, ext_opcode_lgWordGreater] val opcode_lgWordGreaterEq = SimpleCode [opcode_escape, ext_opcode_lgWordGreaterEq] val opcode_lgWordAdd = SimpleCode [opcode_escape, ext_opcode_lgWordAdd] val opcode_lgWordSub = SimpleCode [opcode_escape, ext_opcode_lgWordSub] val opcode_lgWordMult = SimpleCode [opcode_escape, ext_opcode_lgWordMult] val opcode_lgWordDiv = SimpleCode [opcode_escape, ext_opcode_lgWordDiv] val opcode_lgWordMod = SimpleCode [opcode_escape, ext_opcode_lgWordMod] val opcode_lgWordAnd = SimpleCode [opcode_escape, ext_opcode_lgWordAnd] val opcode_lgWordOr = SimpleCode [opcode_escape, ext_opcode_lgWordOr] val opcode_lgWordXor = SimpleCode [opcode_escape, ext_opcode_lgWordXor] val opcode_lgWordShiftLeft = SimpleCode [opcode_escape, ext_opcode_lgWordShiftLeft] val opcode_lgWordShiftRLog = SimpleCode [opcode_escape, ext_opcode_lgWordShiftRLog] val opcode_lgWordShiftRArith = SimpleCode [opcode_escape, ext_opcode_lgWordShiftRArith] val opcode_realEqual = SimpleCode [opcode_escape, ext_opcode_realEqual] val opcode_realLess = SimpleCode [opcode_escape, ext_opcode_realLess] val opcode_realLessEq = SimpleCode [opcode_escape, ext_opcode_realLessEq] val opcode_realGreater = SimpleCode [opcode_escape, ext_opcode_realGreater] val opcode_realGreaterEq = SimpleCode [opcode_escape, ext_opcode_realGreaterEq] val opcode_realUnordered = SimpleCode [opcode_escape, ext_opcode_realUnordered] val opcode_realAdd = SimpleCode [opcode_escape, ext_opcode_realAdd] val opcode_realSub = SimpleCode [opcode_escape, ext_opcode_realSub] val opcode_realMult = SimpleCode [opcode_escape, ext_opcode_realMult] val opcode_realDiv = SimpleCode [opcode_escape, ext_opcode_realDiv] and opcode_floatAbs = SimpleCode [opcode_escape, ext_opcode_floatAbs] and opcode_floatNeg = SimpleCode [opcode_escape, ext_opcode_floatNeg] val opcode_floatEqual = SimpleCode [opcode_escape, ext_opcode_floatEqual] val opcode_floatLess = SimpleCode [opcode_escape, ext_opcode_floatLess] val opcode_floatLessEq = SimpleCode [opcode_escape, ext_opcode_floatLessEq] val opcode_floatGreater = SimpleCode [opcode_escape, ext_opcode_floatGreater] val opcode_floatGreaterEq = SimpleCode [opcode_escape, ext_opcode_floatGreaterEq] val opcode_floatUnordered = SimpleCode [opcode_escape, ext_opcode_floatUnordered] val opcode_floatAdd = SimpleCode [opcode_escape, ext_opcode_floatAdd] val opcode_floatSub = SimpleCode [opcode_escape, ext_opcode_floatSub] val opcode_floatMult = SimpleCode [opcode_escape, ext_opcode_floatMult] val opcode_floatDiv = SimpleCode [opcode_escape, ext_opcode_floatDiv] val opcode_getThreadId = SimpleCode [opcode_getThreadId] val opcode_allocWordMemory = SimpleCode [opcode_allocWordMemory] val opcode_alloc_ref = SimpleCode [opcode_alloc_ref] val opcode_loadMLWord = SimpleCode [opcode_loadMLWord] val opcode_loadMLByte = SimpleCode [opcode_loadMLByte] val opcode_loadC8 = SimpleCode [opcode_escape, ext_opcode_loadC8] val opcode_loadC16 = SimpleCode [opcode_escape, ext_opcode_loadC16] val opcode_loadC32 = SimpleCode [opcode_escape, ext_opcode_loadC32] val opcode_loadC64 = SimpleCode [opcode_escape, ext_opcode_loadC64] val opcode_loadCFloat = SimpleCode [opcode_escape, ext_opcode_loadCFloat] val opcode_loadCDouble = SimpleCode [opcode_escape, ext_opcode_loadCDouble] val opcode_loadUntagged = SimpleCode [opcode_loadUntagged] val opcode_storeMLWord = SimpleCode [opcode_storeMLWord] val opcode_storeMLByte = SimpleCode [opcode_storeMLByte] val opcode_storeC8 = SimpleCode [opcode_escape, ext_opcode_storeC8] val opcode_storeC16 = SimpleCode [opcode_escape, ext_opcode_storeC16] val opcode_storeC32 = SimpleCode [opcode_escape, ext_opcode_storeC32] val opcode_storeC64 = SimpleCode [opcode_escape, ext_opcode_storeC64] val opcode_storeCFloat = SimpleCode [opcode_escape, ext_opcode_storeCFloat] val opcode_storeCDouble = SimpleCode [opcode_escape, ext_opcode_storeCDouble] val opcode_storeUntagged = SimpleCode [opcode_storeUntagged] val opcode_blockMoveWord = SimpleCode [opcode_blockMoveWord] val opcode_blockMoveByte = SimpleCode [opcode_blockMoveByte] val opcode_blockEqualByte = SimpleCode [opcode_blockEqualByte] val opcode_blockCompareByte = SimpleCode [opcode_blockCompareByte] val opcode_deleteHandler = SimpleCode [opcode_deleteHandler] val opcode_allocCSpace = SimpleCode [opcode_escape, ext_opcode_allocCSpace] val opcode_freeCSpace = SimpleCode [opcode_escape, ext_opcode_freeCSpace] structure Sharing = struct type code = code type opcode = opcode type labels = labels type closureRef = closureRef end end; diff --git a/mlsource/MLCompiler/CodeTree/CODETREE.ML b/mlsource/MLCompiler/CodeTree/CODETREE.ML index f5da39d7..887f11ea 100644 --- a/mlsource/MLCompiler/CodeTree/CODETREE.ML +++ b/mlsource/MLCompiler/CodeTree/CODETREE.ML @@ -1,606 +1,606 @@ (* Copyright (c) 2012,13,15-20 David C.J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) functor CODETREE ( -structure DEBUG: DEBUGSIG +structure DEBUG: DEBUG structure PRETTY : PRETTYSIG structure BASECODETREE: BaseCodeTreeSig structure CODETREE_FUNCTIONS: CodetreeFunctionsSig structure BACKEND: sig type codetree type machineWord = Address.machineWord val codeGenerate: codetree * int * Universal.universal list -> (unit -> machineWord) * Universal.universal list structure Foreign: FOREIGNCALLSIG structure Sharing : sig type codetree = codetree end end structure OPTIMISER: sig type codetree and envSpecial and codeBinding val codetreeOptimiser: codetree * Universal.universal list * int -> { numLocals: int, general: codetree, bindings: codeBinding list, special: envSpecial } structure Sharing: sig type codetree = codetree and envSpecial = envSpecial and codeBinding = codeBinding end end sharing type PRETTY.pretty = BASECODETREE.pretty sharing BASECODETREE.Sharing = CODETREE_FUNCTIONS.Sharing = BACKEND.Sharing = OPTIMISER.Sharing ) : CODETREESIG = struct open Address; open StretchArray; open BASECODETREE; open PRETTY; open CODETREE_FUNCTIONS exception InternalError = Misc.InternalError and Interrupt = Thread.Thread.Interrupt infix 9 sub; fun mkDec (laddr, res) = Declar{value = res, addr = laddr, use=[]} fun deExtract(Extract ext) = ext | deExtract _ = raise InternalError "deExtract" datatype level = Level of { lev: int, closure: createClosure, lookup: int * int * bool -> loadForm } local (* We can have locals at the outer level. *) fun bottomLevel(addr, 0, false) = if addr < 0 then raise InternalError "load: negative" else LoadLocal addr | bottomLevel _ = (* Either the level is wrong or it's a parameter. *) raise InternalError "bottom level" in val baseLevel = Level { lev = 0, closure = makeClosure(), lookup = bottomLevel } end fun newLevel (Level{ lev, lookup, ...}) = let val closureList = makeClosure() val makeClosure = addToClosure closureList fun check n = if n < 0 then raise InternalError "load: negative" else n fun thisLevel(addr, level, isParam) = if level < 0 then raise InternalError "mkLoad: level must be non-negative" else if level > 0 then makeClosure(lookup(addr, level-1, isParam)) else (* This level *) if isParam then LoadArgument(check addr) else LoadLocal(check addr) in Level { lev = lev+1, closure = closureList, lookup = thisLevel } end fun getClosure(Level{ closure, ...}) = List.map Extract (extractClosure closure) fun mkLoad (addr, Level { lev = newLevel, lookup, ... } , Level { lev = oldLevel, ... }) = Extract(lookup(addr, newLevel - oldLevel, false)) and mkLoadParam(addr, Level { lev = newLevel, lookup, ... } , Level { lev = oldLevel, ... }) = Extract(lookup(addr, newLevel - oldLevel, true)) (* Transform a function so that free variables are converted to closure form. Returns the maximum local address used. *) fun genCode(pt, debugSwitches, numLocals) = let val printCodeTree = DEBUG.getParameter DEBUG.codetreeTag debugSwitches and compilerOut = PRETTY.getCompilerOutput debugSwitches (* val printCodeTree = true and compilerOut = PRETTY.prettyPrint(TextIO.print, 70) *) (* If required, print it first. This is the code that the front-end has produced. *) val () = if printCodeTree then compilerOut(pretty pt) else () (* This ensures that everything is printed just before it is code-generated. *) fun codeAndPrint(code, localCount) = let val () = if printCodeTree then compilerOut (BASECODETREE.pretty code) else (); in BACKEND.codeGenerate(code, localCount, debugSwitches) end (* Optimise it. *) val { numLocals = localCount, general = gen, bindings = decs, special = spec } = OPTIMISER.codetreeOptimiser(pt, debugSwitches, numLocals) (* At this stage we have a "general" value and also, possibly a "special" value. We could simply create mkEnv(decs, gen) and run preCode and genCode on that. However, we would lose the ability to insert any inline functions from this code into subsequent top-level expressions. We can't simply retain the "special" entry either because that may refer to values that have to be created once when the code is run. Such values will be referenced by "load" entries which refer to entries in the "decs". We construct a tuple which will contain the actual values after the code is run. Then if we want the value at some time in the future when we use something from the "special" entry we can extract the corresponding value from this tuple. Previously, this code always generated a tuple containing every declaration. That led to some very long compilation times because the back-end has some code which is quadratic in the number of entries on the stack. We now try to prune bindings by only generating the tuple if we have an inline function somewhere and only generating bindings we actually need. *) fun simplifySpec (EnvSpecTuple(size, env)) = let (* Get all the field entries. *) fun simpPair (gen, spec) = (gen, simplifySpec spec) val fields = List.tabulate(size, simpPair o env) in if List.all(fn (_, EnvSpecNone) => true | _ => false) fields then EnvSpecNone else EnvSpecTuple(size, fn n => List.nth(fields, n)) end | simplifySpec s = s (* None or inline function. *) in case simplifySpec spec of EnvSpecNone => let val (code, props) = codeAndPrint (mkEnv(decs, gen), localCount) in fn () => Constnt(code(), props) end | simpleSpec => let (* The bindings are marked using a three-valued mark. A binding is needed if it is referenced in any way. During the scan to find the references we need to avoid processing an entry that has already been processed but it is possible that a binding may be referenced as a general value only (e.g. from a function closure) and separately as a special value. See Test148.ML *) datatype visit = UnVisited | VisitedGeneral | VisitedSpecial local val refArray = Array.array(localCount, UnVisited) fun findDecs EnvSpecNone = () | findDecs (EnvSpecTuple(size, env)) = let val fields = List.tabulate(size, env) in List.app processGenAndSpec fields end | findDecs (EnvSpecInlineFunction({closure, ...}, env)) = let val closureItems = List.tabulate(List.length closure, env) in List.app processGenAndSpec closureItems end | findDecs (EnvSpecUnary _) = () | findDecs (EnvSpecBinary _) = () and processGenAndSpec (gen, spec) = (* The spec part needs only to be processed if this entry has not yet been visited, *) case gen of EnvGenLoad(LoadLocal addr) => let val previous = Array.sub(refArray, addr) in case (previous, spec) of (VisitedSpecial, _) => () (* Fully done *) | (VisitedGeneral, EnvSpecNone) => () (* Nothing useful *) | (_, EnvSpecNone) => (* We need this entry but we don't have any special entry to process. We could find another reference with a special entry. *) Array.update(refArray, addr, VisitedGeneral) | (_, _) => ( (* This has a special entry. Mark it and process. *) Array.update(refArray, addr, VisitedSpecial); findDecs spec ) end | EnvGenConst _ => () | _ => raise InternalError "doGeneral: not LoadLocal or Constant" val () = findDecs simpleSpec in (* Convert to an immutable data structure. This will continue to be referenced in any inline function after the code has run. *) val refVector = Array.vector refArray end val decArray = Array.array(localCount, CodeZero) fun addDec(addr, dec) = if Vector.sub(refVector, addr) <> UnVisited then Array.update(decArray, addr, dec) else () fun addDecs(Declar{addr, ...}) = addDec(addr, mkLoadLocal addr) | addDecs(RecDecs decs) = List.app(fn {addr, ...} => addDec(addr, mkLoadLocal addr)) decs | addDecs(NullBinding _) = () | addDecs(Container{addr, size, ...}) = addDec(addr, mkTupleFromContainer(addr, size)) val () = List.app addDecs decs (* Construct the tuple and add the "general" value at the start. *) val resultTuple = mkTuple(gen :: Array.foldr(op ::) nil decArray) (* Now generate the machine code and return it as a function that can be called. *) val (code, codeProps) = codeAndPrint (mkEnv (decs, resultTuple), localCount) in (* Return a function that executes the compiled code and then creates the final "global" value as the result. *) fn () => let local (* Execute the code. This will perform any side-effects the user has programmed and may raise an exception if that is required. *) val resVector = code () (* The result is a vector containing the "general" value as the first word and the evaluated bindings for any "special" entries in subsequent words. *) val decVals : address = if isShort resVector then raise InternalError "Result vector is not an address" else toAddress resVector in fun resultWordN n = loadWord (decVals, n) (* Get the general value, the zero'th entry in the vector. *) val generalVal = resultWordN 0w0 (* Get the properties for a field in the tuple. Because the result is a tuple all the properties should be contained in a tupleTag entry. *) val fieldProps = case Option.map (Universal.tagProject CodeTags.tupleTag) (List.find(Universal.tagIs CodeTags.tupleTag) codeProps) of NONE => (fn _ => []) | SOME p => (fn n => List.nth(p, n)) val generalProps = fieldProps 0 end (* Construct a new environment so that when an entry is looked up the corresponding constant is returned. *) fun newEnviron (oldEnv) args = let val (oldGeneral, oldSpecial) = oldEnv args val genPair = case oldGeneral of EnvGenLoad(LoadLocal addr) => ( (* For the moment retain this check. It's better to have an assertion failure than a segfault. *) Vector.sub(refVector, addr) <> UnVisited orelse raise InternalError "Reference to non-existent binding"; (resultWordN(Word.fromInt addr+0w1), fieldProps(addr+1)) ) | EnvGenConst c => c | _ => raise InternalError "codetree newEnviron: Not Extract or Constnt" val specVal = mapSpec oldSpecial in (EnvGenConst genPair, specVal) end and mapSpec EnvSpecNone = EnvSpecNone | mapSpec (EnvSpecTuple(size, env)) = EnvSpecTuple(size, newEnviron env) | mapSpec (EnvSpecInlineFunction(spec, env)) = EnvSpecInlineFunction(spec, (newEnviron env)) | mapSpec (EnvSpecUnary _) = EnvSpecNone | mapSpec (EnvSpecBinary _) = EnvSpecNone in (* and return the whole lot as a global value. *) Constnt(generalVal, setInline(mapSpec simpleSpec) generalProps) end end end (* genCode *) (* Constructor functions for the front-end of the compiler. *) local fun mkSimpleFunction inlineType (lval, args, name, closure, numLocals) = { body = lval, isInline = inlineType, name = if name = "" then "" else name, closure = map deExtract closure, argTypes = List.tabulate(args, fn _ => (GeneralType, [])), resultType = GeneralType, localCount = numLocals, recUse = [] } in val mkProc = Lambda o mkSimpleFunction DontInline (* Normal function *) and mkInlproc = Lambda o mkSimpleFunction InlineAlways (* Explicitly inlined by the front-end *) (* Unless Compiler.inlineFunctor is false functors are treated as macros and expanded when they are applied. Unlike core-language functions they are not first-class values so if they are inline the "value" returned in the initial binding can just be zero except if there is something in the closure. Almost always the closure will be empty since free variables will come from previous topdecs and will be constants, The exception is if a structure and a functor using the structure appear in the same topdec (no semicolon between them). In that case we can't leave it. We would have to update the closure even if we leave the body untouched but we could have closure entries that are constants. e.g. structure S = struct val x = 1 end functor F() = struct open S end *) fun mkMacroProc (args as (_, _, _, [], _)) = Constnt(toMachineWord 0, setInline ( EnvSpecInlineFunction(mkSimpleFunction InlineAlways args, fn _ => raise InternalError "mkMacroProc: closure")) []) | mkMacroProc args = Lambda(mkSimpleFunction InlineAlways args) end local fun mkFunWithTypes inlineType { body, argTypes=argsAndTypes, resultType, name, closure, numLocals } = Lambda { body = body, isInline = inlineType, name = if name = "" then "" else name, closure = map deExtract closure, argTypes = map (fn t => (t, [])) argsAndTypes, resultType = resultType, localCount = numLocals, recUse = [] } in val mkFunction = mkFunWithTypes DontInline and mkInlineFunction = mkFunWithTypes InlineAlways end fun mkEval (ct, clist) = Eval { function = ct, argList = List.map(fn c => (c, GeneralType)) clist, resultType=GeneralType } fun mkCall(func, argsAndTypes, resultType) = Eval { function = func, argList = argsAndTypes, resultType=resultType } (* Basic built-in operations. *) fun mkUnary (oper, arg1) = Unary { oper = oper, arg1 = arg1 } and mkBinary (oper, arg1, arg2) = Binary { oper = oper, arg1 = arg1, arg2 = arg2 } val getCurrentThreadId = Nullary{oper=BuiltIns.GetCurrentThreadId} val getCurrentThreadIdFn = mkInlproc(getCurrentThreadId, 1 (* Ignores argument *), "GetThreadId()", [], 0) val checkRTSException = Nullary{oper=BuiltIns.CheckRTSException} fun mkAllocateWordMemory (numWords, flags, initial) = AllocateWordMemory { numWords = numWords, flags = flags, initial = initial } val mkAllocateWordMemoryFn = mkInlproc( mkAllocateWordMemory(mkInd(0, mkLoadArgument 0), mkInd(1, mkLoadArgument 0), mkInd(2, mkLoadArgument 0)), 1, "AllocateWordMemory()", [], 0) (* Builtins wrapped as functions. N.B. These all take a single argument which may be a tuple. *) fun mkUnaryFn oper = mkInlproc(mkUnary(oper, mkLoadArgument 0), 1, BuiltIns.unaryRepr oper ^ "()", [], 0) and mkBinaryFn oper = mkInlproc(mkBinary(oper, mkInd(0, mkLoadArgument 0), mkInd(1, mkLoadArgument 0)), 1, BuiltIns.binaryRepr oper ^ "()", [], 0) local open BuiltIns (* Word equality. The value of isSigned doesn't matter. *) val eqWord = WordComparison{test=TestEqual, isSigned=false} in fun mkNot arg = Unary{oper=NotBoolean, arg1=arg} and mkIsShort arg = Unary{oper=IsTaggedValue, arg1=arg} and mkEqualTaggedWord (arg1, arg2) = Binary{oper=eqWord, arg1=arg1, arg2=arg2} and mkEqualPointerOrWord (arg1, arg2) = Binary{oper=PointerEq, arg1=arg1, arg2=arg2} val equalTaggedWordFn = (* This takes two words, not a tuple. *) mkInlproc(mkBinary(eqWord, mkLoadArgument 0, mkLoadArgument 1), 2, "EqualWord()", [], 0) and equalPointerOrWordFn = (* This takes two words, not a tuple. *) mkInlproc(mkBinary(PointerEq, mkLoadArgument 0, mkLoadArgument 1), 2, "EqualWord()", [], 0) end fun mkLoadOperation(oper, base, index) = LoadOperation{kind=oper, address={base=base, index=SOME index, offset=0}} fun mkLoadOperationFn oper = mkInlproc(mkLoadOperation(oper, mkInd(0, mkLoadArgument 0), mkInd(1, mkLoadArgument 0)), 1, "loadOperation()", [], 0) fun mkStoreOperation(oper, base, index, value) = StoreOperation{kind=oper, address={base=base, index=SOME index, offset=0}, value=value} fun mkStoreOperationFn oper = mkInlproc(mkStoreOperation(oper, mkInd(0, mkLoadArgument 0), mkInd(1, mkLoadArgument 0), mkInd(2, mkLoadArgument 0)), 1, "storeOperation()", [], 0) fun mkBlockOperation {kind, leftBase, leftIndex, rightBase, rightIndex, length } = BlockOperation { kind = kind, sourceLeft={base=leftBase, index=SOME leftIndex, offset=0}, destRight={base=rightBase, index=SOME rightIndex, offset=0}, length=length} (* Construct a function that takes five arguments. The order is left-base, right-base, left-index, right-index, length. *) fun mkBlockOperationFn kind = mkInlproc( mkBlockOperation{kind=kind, leftBase=mkInd(0, mkLoadArgument 0), rightBase=mkInd(1, mkLoadArgument 0), leftIndex=mkInd(2, mkLoadArgument 0), rightIndex=mkInd(3, mkLoadArgument 0), length=mkInd(4, mkLoadArgument 0)}, 1, "blockOperation()", [], 0) fun identityFunction (name : string) : codetree = mkInlproc (mkLoadArgument 0, 1, name, [], 0) (* Returns its argument. *); (* Test a tag value. *) fun mkTagTest(test: codetree, tagValue: word, maxTag: word) = TagTest {test=test, tag=tagValue, maxTag=maxTag } fun mkHandle (exp, handler, exId) = Handle {exp = exp, handler = handler, exPacketAddr = exId} fun mkStr (strbuff:string) = Constnt (toMachineWord strbuff, []) (* If we have multiple references to a piece of code we may have to save it in a temporary and then use it from there. If the code has side-effects we certainly must do that to ensure that the side-effects are done exactly once and in the correct order, however if the code is just a constant or a load we can reduce the amount of code we generate by simply returning the original code. *) fun multipleUses (code as Constnt _, _, _) = {load = (fn _ => code), dec = []} (* | multipleUses (code as Extract(LoadLegacy{addr, level=loadLevel, ...}), _, level) = let (* May have to adjust the level. *) fun loadFn lev = if lev = level then code else mkLoad (addr, loadLevel + lev, level)) in {load = loadFn, dec = []} end | multipleUses (code as Extract(LoadLocal addr), _, level) = let (* May have to adjust the level. *) fun loadFn lev = if lev = level then code else mkLoad (addr, lev - level) in {load = loadFn, dec = []} end | multipleUses (code as Extract(LoadArgument _), _, level) = let (* May have to adjust the level. *) fun loadFn lev = if lev = level then code else raise InternalError "multipleUses: different level" (*else mkLoad (addr, lev - level)*) in {load = loadFn, dec = []} end | multipleUses (Extract _, _, _) = raise InternalError "multipleUses: TODO" *) | multipleUses (code, nextAddress, level) = let val addr = nextAddress(); fun loadFn lev = mkLoad (addr, lev, level); in {load = loadFn, dec = [mkDec (addr, code)]} end (* multipleUses *); fun mkMutualDecs [] = raise InternalError "mkMutualDecs: empty declaration list" | mkMutualDecs l = let fun convertDec(a, Lambda lam) = {lambda = lam, addr = a, use=[]} | convertDec _ = raise InternalError "mkMutualDecs: Recursive declaration is not a function" in RecDecs(List.map convertDec l) end val mkNullDec = NullBinding fun mkContainer(addr, size, setter) = Container{addr=addr, size=size, use=[], setter=setter} val mkIf = Cond and mkRaise = Raise fun mkConst v = Constnt(v, []) (* For the moment limit these to general arguments. *) fun mkLoop args = Loop (List.map(fn c => (c, GeneralType)) args) and mkBeginLoop(exp, args) = BeginLoop{loop=exp, arguments=List.map(fn(i, v) => ({value=v, addr=i, use=[]}, GeneralType)) args} fun mkWhile(b, e) = (* Generated as if b then (e; ) else (). *) mkBeginLoop(mkIf(b, mkEnv([NullBinding e], mkLoop[]), CodeZero), []) (* We previously had conditional-or and conditional-and as separate instructions. I've taken them out since they can be implemented just as efficiently as a normal conditional. In addition they were interfering with the optimisation where the second expression contained the last reference to something. We needed to add a "kill entry" to the other branch but there wasn't another branch to add it to. DCJM 7/12/00. *) fun mkCor(xp1, xp2) = mkIf(xp1, CodeTrue, xp2); fun mkCand(xp1, xp2) = mkIf(xp1, xp2, CodeZero); val mkSetContainer = fn (container, tuple, size) => mkSetContainer(container, tuple, BoolVector.tabulate(size, fn _ => true)) (* We don't generate the +, -, < etc operations directly here. Instead we create functions that the basis library can use to create the final versions by applying these functions to the arguments and an RTS function. The inline expansion system takes care of all the optimisation. An arbitrary precision operation takes a tuple consisting of a pair of arguments and a function. The code that is constructed checks both arguments to see if they are short. If they are not or the short precision operation overflows the code to call the function is executed. *) local val argX = mkInd(0, mkLoadArgument 0) and argY = mkInd(1, mkLoadArgument 0) val testShort = mkCand(mkIsShort argX, mkIsShort argY) val longCall = mkEval(mkInd(2, mkLoadArgument 0), [mkTuple[argX, argY]]) in fun mkArbitraryFn (oper as ArbArith arith) = mkInlproc( Arbitrary{oper=oper, shortCond=testShort, arg1=argX, arg2=argY, longCall=longCall }, 1, "Arbitrary" ^ BuiltIns.arithRepr arith ^ "()", [], 0) | mkArbitraryFn (oper as ArbCompare test) = (* The long function here is PolyCompareArbitrary which returns -1,0,+1 so the result has to be compared with zero. *) let val comparedResult = Binary{oper=BuiltIns.WordComparison{test=test, isSigned=true}, arg1=longCall, arg2=CodeZero} in mkInlproc( Arbitrary{oper=oper, shortCond=testShort, arg1=argX, arg2=argY, longCall=comparedResult }, 1, "Arbitrary" ^ BuiltIns.testRepr test ^ "()", [], 0) end end structure Foreign = BACKEND.Foreign structure Sharing = struct type machineWord = machineWord type codetree = codetree type pretty = pretty type argumentType=argumentType type codeBinding = codeBinding type level = level end end (* CODETREE functor body *); diff --git a/mlsource/MLCompiler/CodeTree/CODETREE_CODEGEN_CONSTANT_FUNCTIONS.sml b/mlsource/MLCompiler/CodeTree/CODETREE_CODEGEN_CONSTANT_FUNCTIONS.sml index acdc4ca6..ccac2d40 100644 --- a/mlsource/MLCompiler/CodeTree/CODETREE_CODEGEN_CONSTANT_FUNCTIONS.sml +++ b/mlsource/MLCompiler/CodeTree/CODETREE_CODEGEN_CONSTANT_FUNCTIONS.sml @@ -1,315 +1,315 @@ (* Copyright (c) 2013, 2015, 2017, 2020 David C.J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) (* If a function has an empty closure it can be code-generated immediately. That may allow other functions or tuples to be generated immediately as well. As well as avoiding run-time allocations this also allows the code-generator to use calls/jumps to constant addresses. *) functor CODETREE_CODEGEN_CONSTANT_FUNCTIONS ( structure BASECODETREE: BaseCodeTreeSig structure CODETREE_FUNCTIONS: CodetreeFunctionsSig structure BACKEND: CodegenTreeSig - structure DEBUG: DEBUGSIG + structure DEBUG: DEBUG structure PRETTY : PRETTYSIG structure CODE_ARRAY: CODEARRAYSIG sharing BASECODETREE.Sharing = CODETREE_FUNCTIONS.Sharing = BACKEND.Sharing = PRETTY.Sharing = CODE_ARRAY.Sharing ): sig type codetree type machineWord = Address.machineWord val codeGenerate: codetree * int * Universal.universal list -> (unit -> machineWord) * Universal.universal list structure Foreign: FOREIGNCALLSIG structure Sharing: sig type codetree = codetree end end = struct open BASECODETREE open CODETREE_FUNCTIONS open CODE_ARRAY open Address exception InternalError = Misc.InternalError datatype lookupVal = EnvGenLoad of loadForm | EnvGenConst of machineWord * Universal.universal list type cgContext = { lookupAddr: loadForm -> lookupVal, enterConstant: int * (machineWord * Universal.universal list) -> unit, debugArgs: Universal.universal list } (* Code-generate a function or set of mutually recursive functions that contain no free variables and run the code to return the address. This allows us to further fold the address as a constant if, for example, it is used in a tuple. *) fun codeGenerateToConstant(lambda, debugSwitches, closure) = let val () = if DEBUG.getParameter DEBUG.codetreeAfterOptTag debugSwitches then PRETTY.getCompilerOutput debugSwitches (BASECODETREE.pretty(Lambda lambda)) else () in BACKEND.codeGenerate(lambda, debugSwitches, closure) end (* If we are code-generating a function immediately we make a one-word mutable cell that will subsequently contain the address of the code. After it is locked this becomes the closure of the function. By creating it here we can turn recursive references into constant references before we actually compile the function. *) fun cgFuns ({ lookupAddr, ...}: cgContext) (Extract ext) = ( (* Look up the entry. It may now be a constant. If it isn't it may still have changed if it is a closure entry and other closure entries have been replaced by constants. *) case lookupAddr ext of EnvGenLoad load => SOME(Extract load) | EnvGenConst w => SOME(Constnt w) ) | cgFuns (context as {debugArgs, ...}) (Lambda lambda) = let val copied as { closure=resultClosure, ...} = cgLambda(context, lambda, EnvGenLoad LoadRecursive) in case resultClosure of [] => let (* Create a "closure" for the function. *) val closure = makeConstantClosure() (* Replace any recursive references by references to the closure. There may be inner functions that only make recursive calls to this. By turning the recursive references into constants we may be able to compile them immediately as well. *) val repLambda = cgLambda(context, lambda, EnvGenConst(toMachineWord closure, [])) val props = codeGenerateToConstant(repLambda, debugArgs, closure) in SOME(Constnt(toMachineWord closure, props)) end | _ => SOME(Lambda copied) end | cgFuns (context as { enterConstant, debugArgs, ...}) (Newenv(envBindings, envExp)) = let (* First expand out any mutually-recursive bindings. This ensures that if we have any RecDecs left *) val expandedBindings = List.foldr (fn (d, l) => partitionMutualBindings d @ l) [] envBindings fun processBindings(Declar{value, addr, use} :: tail) = ( (* If this is a constant put it in the table otherwise create a binding. *) case mapCodetree (cgFuns context) value of Constnt w => (enterConstant(addr, w); processBindings tail) | code => Declar{value=code, addr=addr, use=use} :: processBindings tail ) | processBindings(NullBinding c :: tail) = NullBinding(mapCodetree (cgFuns context) c) :: processBindings tail | processBindings(RecDecs[{addr, lambda, use}] :: tail) = (* Single recursive bindings - treat as simple binding *) processBindings(Declar{addr=addr, value=Lambda lambda, use = use} :: tail) | processBindings(RecDecs recdecs :: tail) = let (* We know that this forms a strongly connected component so it is only possible to code-generate the group if no function has a free-variable outside the group. Each function must have at least one free variable which is part of the group. *) fun processEntry {addr, lambda, use} = {addr=addr, lambda=cgLambda(context, lambda, EnvGenLoad LoadRecursive), use=use} val processedGroup = map processEntry recdecs (* If every free variable is another member of the group we can code-generate the group. *) local fun closureItemInGroup(LoadLocal n) = List.exists(fn{addr, ...} => n = addr) processedGroup | closureItemInGroup _ = false fun onlyInGroup{lambda={closure, ...}, ...} = List.all closureItemInGroup closure in val canCodeGen = List.all onlyInGroup processedGroup end in if canCodeGen then let open Address (* Create "closures" for each entry. Add these as constants to the table. *) fun createAndEnter {addr, ...} = let val c = makeConstantClosure() in enterConstant(addr, (Address.toMachineWord c, [])); c end val closures = List.map createAndEnter processedGroup (* Code-generate each of the lambdas and store the code in the closure. *) fun processLambda({lambda, addr, ...}, closure) = let val closureAsMachineWord = Address.toMachineWord closure val repLambda = cgLambda(context, lambda, EnvGenConst(closureAsMachineWord, [])) val props = codeGenerateToConstant(repLambda, debugArgs, closure) in (* Include any properties we may have added *) enterConstant(addr, (closureAsMachineWord, props)) end val () = ListPair.appEq processLambda (processedGroup, closures) in processBindings tail (* We've done these *) end else RecDecs processedGroup :: processBindings tail end | processBindings(Container{addr, use, size, setter} :: tail) = Container{addr=addr, use=use, size=size, setter = mapCodetree (cgFuns context) setter} :: processBindings tail | processBindings [] = [] val bindings = processBindings expandedBindings val body = mapCodetree (cgFuns context) envExp in case bindings of [] => SOME body | _ => SOME(Newenv(bindings, body)) end | cgFuns context (Tuple{ fields, isVariant }) = (* Create any constant tuples that have arisen because they contain constant functions. *) SOME((if isVariant then mkDatatype else mkTuple)(map (mapCodetree (cgFuns context)) fields)) | cgFuns _ _ = NONE and cgLambda({lookupAddr, debugArgs, ...}, { body, isInline, name, closure, argTypes, resultType, localCount, recUse}, loadRecursive) = let val cArray = Array.array(localCount, NONE) val newClosure = makeClosure() fun lookupLocal(load as LoadLocal n) = ( case Array.sub(cArray, n) of NONE => EnvGenLoad load | SOME w => EnvGenConst w ) | lookupLocal(LoadClosure n) = ( case lookupAddr(List.nth (closure, n)) of EnvGenLoad load => EnvGenLoad(addToClosure newClosure load) | c as EnvGenConst _ => c ) | lookupLocal LoadRecursive = loadRecursive | lookupLocal load = EnvGenLoad load (* Argument *) val context = { lookupAddr = lookupLocal, enterConstant = fn (n, w) => Array.update(cArray, n, SOME w), debugArgs = debugArgs } (* Process the body to deal with any sub-functions and also to bind in any constants from free variables. *) val newBody = mapCodetree (cgFuns context) body (* Build the resulting lambda. *) val resultClosure = extractClosure newClosure in { body = newBody, isInline = isInline, name = name, closure = resultClosure, argTypes = argTypes, resultType = resultType, localCount = localCount, recUse = recUse } end fun codeGenerate(original, nLocals, debugArgs) = let val cArray = Array.array(nLocals, NONE) fun lookupAddr(load as LoadLocal n) = ( case Array.sub(cArray, n) of NONE => EnvGenLoad load | SOME w => EnvGenConst w ) | lookupAddr _ = raise InternalError "lookupConstant: top-level reached" val context = { lookupAddr = lookupAddr, enterConstant = fn (n, w) => Array.update(cArray, n, SOME w), debugArgs = debugArgs } val resultCode = mapCodetree (cgFuns context) original (* Turn this into a lambda to code-generate. *) val lambda:lambdaForm = { body = resultCode, isInline = DontInline, name = "", closure = [], argTypes = [(GeneralType, [])], resultType = GeneralType, localCount = nLocals, recUse = [] } val closure = makeConstantClosure() val props = BACKEND.codeGenerate(lambda, debugArgs, closure) (* The code may consist of tuples (i.e. compiled ML structures) containing a mixture of Loads, where the values are yet to be compiled, and Constants, where the code has now been compiled. We need to extract any properties from the constants and return the whole lot as tuple properties. *) fun extractProps(Constnt(_, p)) = p | extractProps(Extract ext) = ( case lookupAddr ext of EnvGenLoad _ => [] | EnvGenConst(_, p) => p ) | extractProps(Tuple{fields, ...}) = let val fieldProps = map extractProps fields in if List.all null fieldProps then [] else [Universal.tagInject CodeTags.tupleTag fieldProps] end | extractProps(Newenv(_, exp)) = extractProps exp | extractProps _ = [] val newProps = extractProps original (* Cast this as a function. It is a function with a single argument. *) val resultFunction: unit -> machineWord = RunCall.unsafeCast closure in (resultFunction, CodeTags.mergeTupleProps(newProps, props)) end structure Foreign = BACKEND.Foreign structure Sharing = struct type codetree = codetree end end; diff --git a/mlsource/MLCompiler/CodeTree/CODETREE_LAMBDA_LIFT.sml b/mlsource/MLCompiler/CodeTree/CODETREE_LAMBDA_LIFT.sml index 398615cb..127a7803 100644 --- a/mlsource/MLCompiler/CodeTree/CODETREE_LAMBDA_LIFT.sml +++ b/mlsource/MLCompiler/CodeTree/CODETREE_LAMBDA_LIFT.sml @@ -1,498 +1,498 @@ (* Copyright (c) 2015, 2020 David C.J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) (* Lambda-lifting. If every call point to a function can be identified we can lift the free variables as extra parameters. This avoids the need for a closure on the heap. It makes stack-closures largely redundant. The advantages of lambda-lifting over stack closures are that the containing function of a stack-closure cannot call a stack-closure with tail-recursion because the closure must remain on the stack until the function returns. Also we can lambda-lift a function even if it is used in a function that requires a full closure whereas we cannot use a stack closure for a function if the closure would be used in a full, heap closure. This pass is called after optimisation and after any functions that have empty closures have been code-generated to constants. *) functor CODETREE_LAMBDA_LIFT ( structure BASECODETREE: BaseCodeTreeSig structure CODETREE_FUNCTIONS: CodetreeFunctionsSig structure BACKEND: CodegenTreeSig - structure DEBUG: DEBUGSIG + structure DEBUG: DEBUG structure PRETTY : PRETTYSIG structure CODE_ARRAY: CODEARRAYSIG sharing BASECODETREE.Sharing = CODETREE_FUNCTIONS.Sharing = BACKEND.Sharing = PRETTY.Sharing = CODE_ARRAY.Sharing ): CodegenTreeSig = struct open BASECODETREE open CODETREE_FUNCTIONS exception InternalError = Misc.InternalError (* First pass: identify the functions whose only use are calls. This annotates the tree by setting the "use" or any bindings or recursive uses that require a closure to [UseGeneral]. *) fun checkBody(code: codetree, closureRef: int -> unit, recursiveRef: unit -> unit, localCount) = let (* An entry for each local binding. Set to true if we find a non-call reference. *) val localsNeedClosures = BoolArray.array(localCount, false) fun markExtract(LoadLocal n) = BoolArray.update(localsNeedClosures, n, true) | markExtract LoadRecursive = recursiveRef() | markExtract(LoadClosure n) = closureRef n | markExtract(LoadArgument _) = () fun checkCode(ext as Extract load) = (markExtract load; SOME ext) (* These are loads which aren't calls. If they are functions they need closures. *) | checkCode(Eval{function as Extract _, argList, resultType}) = (* A call of a function. We don't need to mark the function as needing a closure. *) SOME( Eval{function=function, argList=map(fn (c, t) => (checkMapCode c, t)) argList, resultType=resultType}) | checkCode(Lambda lambda) = SOME(Lambda(checkLambda lambda)) | checkCode(Newenv(decs, exp)) = (* We want to add [UseGeneral] to bindings that require closures. To do that we have to process the bindings in reverse order. *) let val processedExp = checkMapCode exp (* The expression first. *) fun getFlag addr = if BoolArray.sub(localsNeedClosures, addr) then [UseGeneral] else [] fun processDecs [] = [] | processDecs ((Declar { value, addr, ...}) :: tail) = let val pTail = processDecs tail (* Tail first *) val pValue = checkMapCode value in Declar{value = pValue, addr=addr, use=getFlag addr} :: pTail end | processDecs (RecDecs l :: tail) = let val pTail = processDecs tail (* Tail first *) (* Process the lambdas. Because they're mutually recursive this may set the closure flag for others in the set. *) val pLambdas = map (fn {lambda, addr, ...} => {addr=addr, use=[], lambda=checkLambda lambda}) l (* Can now pick up the closure flags. *) val pDecs = map(fn {lambda, addr, ...} => {lambda=lambda, addr=addr, use=getFlag addr}) pLambdas in RecDecs pDecs :: pTail end | processDecs (NullBinding c :: tail) = let val pTail = processDecs tail in NullBinding(checkMapCode c) :: pTail end | processDecs (Container{ addr, size, setter,... } :: tail) = let val pTail = processDecs tail in Container{addr=addr, use=[], size=size, setter=checkMapCode setter} :: pTail end in SOME(Newenv(processDecs decs, processedExp)) end | checkCode _ = NONE and checkLambda({body, closure, localCount, name, argTypes, resultType, ...}) = (* Lambdas - check the function body and any recursive uses. *) let val recNeedsClosure = ref false fun refToRecursive() = recNeedsClosure := true fun refToClosure n = markExtract(List.nth(closure, n)) val processedBody = checkBody(body, refToClosure, refToRecursive, localCount) in {body=processedBody, isInline=DontInline, closure=closure, localCount=localCount, name=name, argTypes=argTypes, resultType=resultType, recUse=if !recNeedsClosure then [UseGeneral] else []} end and checkMapCode code = mapCodetree checkCode code in checkMapCode code end (* Second pass: Actually do the lambda-lifting. *) datatype lift = LiftLoad of loadForm (* Usually unlifted but also for recursive calls. *) | LiftConst of codetree (* A lifted function. *) fun processBody(code: codetree, getClosure: int -> lift * loadForm list, getRecursive: unit -> loadForm list, localCount, debugArgs): codetree = let val processedLambdas: (codetree * loadForm list) option array = Array.array(localCount, NONE) fun findBinding(ext as LoadLocal n) = ( case Array.sub(processedLambdas, n) of SOME (c, l) => (LiftConst c, l) | NONE => (LiftLoad ext, []) ) | findBinding(LoadRecursive) = (LiftLoad LoadRecursive, getRecursive()) (* The code for the recursive case is always LoadRecursive but depending on whether it's been lifted or not there may be extra args. *) | findBinding(LoadClosure n) = getClosure n | findBinding(ext as LoadArgument _) = (LiftLoad ext, []) fun processCode(Eval{function=Extract ext, argList, resultType}) = let (* If this has been lifted we have to add the extra arguments. The function may also now be a constant. *) val (newFunction, extraArgs) = case findBinding ext of (LiftConst c, l) => (c, l) | (LiftLoad e, l) => (Extract e, l) (* Process the original args. There may be functions in there. *) val processedArgs = map(fn (c, t) => (processMapCode c, t)) argList in SOME(Eval{function=newFunction, argList=processedArgs @ map(fn c => (Extract c, GeneralType)) extraArgs, resultType=resultType}) end | processCode(Eval{function=Lambda(lambda as { recUse=[], ...}), argList, resultType}) = (* We have a call to a lambda. This must be a recursive function otherwise it would have been expanded inline. If the recursive references are just calls we can lambda-lift it. *) let val (fnConstnt, extraArgs) = hd(liftLambdas([(lambda, NONE)])) val processedArgs = map(fn (c, t) => (processMapCode c, t)) argList in SOME(Eval{function=fnConstnt, argList=processedArgs @ map(fn c => (Extract c, GeneralType)) extraArgs, resultType=resultType}) end | processCode(Extract ext) = ( (* A load of a binding outside a call. We need to process this to rebuild the closure but if we get a lifted function it's an error. *) case findBinding ext of (LiftLoad e, []) => SOME(Extract e) | _ => raise InternalError "Lifted function out of context" ) | processCode(Lambda lambda) = (* Bare lambda or lambda in binding where we need a closure. This can't be lambda-lifted but we still need to process the body and rebuild the closure. *) SOME(Lambda(processLambdaWithClosure lambda)) | processCode(Newenv(decs, exp)) = let fun processDecs [] = [] | processDecs ((Declar { value = Lambda (lambda as { recUse=[], ...}), addr, use=[]}) :: tail) = let (* We can lambda-lift. This results in a constant which is added to the table. We don't need an entry for the binding. *) val constntAndArgs = hd(liftLambdas[(lambda, SOME addr(*or NONE*))]) in Array.update(processedLambdas, addr, SOME constntAndArgs); processDecs tail end | processDecs ((Declar { value, addr, ...}) :: tail) = (* All other non-recursive bindings. *) Declar{value = processMapCode value, addr=addr, use=[]} :: processDecs tail | processDecs (RecDecs l :: tail) = let (* We only lambda-lift if all the functions are called. We could actually lift all those that are called and leave the others but it's probably not worth it. *) fun checkLift({lambda={recUse=[], ...}, use=[], ...}, true) = true | checkLift _ = false in if List.foldl checkLift true l then let val results = liftLambdas(map(fn{lambda, addr, ...} => (lambda, SOME addr)) l) in (* Add the code of the functions to the array. *) ListPair.appEq( fn (ca, {addr, ...}) => Array.update(processedLambdas, addr, SOME ca)) (results, l); (* And just deal with the rest of the bindings. *) processDecs tail end else let val pLambdas = map (fn {lambda, addr, ...} => {addr=addr, use=[], lambda=processLambdaWithClosure lambda}) l in RecDecs pLambdas :: processDecs tail end end | processDecs (NullBinding c :: tail) = NullBinding(processMapCode c) :: processDecs tail | processDecs (Container{ addr, size, setter,... } :: tail) = Container{addr=addr, use=[], size=size, setter=processMapCode setter} :: processDecs tail in SOME(Newenv(processDecs decs, processMapCode exp)) end | processCode _ = NONE and processLambdaWithClosure({body, closure, localCount, name, argTypes, resultType, ...}) = (* Lambdas that are not to be lifted. They may still have functions inside that can be lifted. They may also refer to functions that have been lifted. *) let (* We have to rebuild the closure. If any of the closure entries were lifted functions they are now constants but their arguments have to be added to the closure. *) val newClosure = makeClosure() fun closureRef n = let val (localFunction, extraArgs) = findBinding(List.nth(closure, n)) (* If the function is a local we have to add it to the closure. If it is a lifted function the function itself will be a constant except in the case of a recursive call. We do have to add the arguments to the closure. *) val resFunction = case localFunction of LiftLoad ext => LiftLoad(addToClosure newClosure ext) | c as LiftConst _ => c val resArgs = map(fn ext => addToClosure newClosure ext) extraArgs in (resFunction, resArgs) end val processedBody = processBody(body, closureRef, fn () => [], localCount, debugArgs) in {body=processedBody, isInline=DontInline, closure=extractClosure newClosure, localCount=localCount, name=name, argTypes=argTypes, resultType=resultType, recUse=[]} end and liftLambdas (bindings: (lambdaForm * int option) list) = (* Lambda-lift one or more functions. The general, but least common, case is a set of mutually recursive functions. More usually we have a single binding of a function or a single anonymous lambda. Lambda-lifting involves replacing the closure with arguments so it can only be used when we can identify all the call sites of the function and add the extra arguments. Because the transformed function has an empty closure (but see below for the mutually-recursive case) it can be code-generated immediately. The code then becomes a constant. There are a few complications. Although the additional, "closure" arguments are taken from the original function closure there may be changes if some of the closure entries are actually lambda-lifted functions. In that case the function may become a constant, and so not need to be included in the arguments, but the additional arguments for that function may need to be added to the closure. The other complication is recursion, especially mutual recursion. If we have references to mutually recursive functions we actually leave those references in the closure. This means that we actually code-generate mutually-recursive functions with non-empty closures but that is allowed if the references are only to other functions in the set. The code-generator sorts that out. *) let (* We need to construct a new common closure. This will be used by all the functions. *) val newClosure = makeClosure() fun closureEntry clItem = let val (localFunction, extraArgs) = findBinding clItem (* If the function is a local we have to add it to the closure. If it is a lifted function the function itself will be a constant except in the case of a recursive call. We do have to add the arguments to the closure. *) val resFunction = case localFunction of LiftLoad ext => LiftLoad(addToClosure newClosure ext) | c as LiftConst _ => c val resArgs = map(fn ext => addToClosure newClosure ext) extraArgs in (resFunction, resArgs) end local (* Check for an address which is one of the recursive set. *) val addressesUsed = List.mapPartial #2 bindings in fun isRecursive(LoadLocal n) = List.exists(fn p => p=n) addressesUsed | isRecursive _ = false end local fun closureItem ext = (* If it's a local we have to check that it's not one of our mutually recursive set. These items aren't going to be passed as arguments. *) if isRecursive ext then () else (closureEntry ext; ()) in val () = List.app(fn ({closure, ...}, _) => List.app closureItem closure) bindings end (* This composite closure is the set of additional arguments we need. *) val transClosure = extractClosure newClosure local val extraArgs = List.map(fn _ => (GeneralType, [])) transClosure val closureSize = List.length transClosure (* Process the function bodies. *) fun transformLambda({body, closure, localCount, name, argTypes, resultType, ...}, addr) = let val argSize = List.length argTypes val recArgs = List.tabulate(closureSize, fn n => LoadArgument(n+argSize)) (* References to other functions in the set are added to a residual closure. *) val residual = makeClosure() fun closureRef clItem = (* We have a reference to the (old) closure item. We need to change that to return the appropriate argument. The exception is that if we have a (recursive) reference to another function in the set we instead use an entry from the residual closure. *) let val oldClosureItem = List.nth(closure, clItem) in if isRecursive oldClosureItem then (LiftLoad(addToClosure residual oldClosureItem), recArgs) else let val (localFunction, resArgs) = closureEntry oldClosureItem fun mapToArg(LoadClosure n) = LoadArgument(n+argSize) | mapToArg _ = raise InternalError "mapToArg" (* Not a closure item. *) val resFunction = case localFunction of LiftLoad ext => LiftLoad(mapToArg ext) | c as LiftConst _ => c in (resFunction, map mapToArg resArgs) end end (* Recursive case - add the extra args. *) and recursiveRef() = recArgs val processedBody = processBody(body, closureRef, recursiveRef, localCount, debugArgs) val lambda = {body=processedBody, isInline=DontInline, closure=extractClosure residual, localCount=localCount, name=name, argTypes=argTypes @ extraArgs, resultType=resultType, recUse=[]} in { lambda=lambda, addr=getOpt(addr, 0), use=[] } end in val bindingsForCode = List.map transformLambda bindings end local (* We may have a single anonymous lambda. In that case we can give it address zero. *) val addresses = map (fn (_, addr) => getOpt(addr, 0)) bindings (* Create "closures" for each entry. These will be set by the code-generator to the code of each function and will become the closures we return. Put them into the table. *) val maxAddr = List.foldl(fn (addr, n) => Int.max(addr, n)) 0 addresses (* To get the constant addresses we create bindings for the functions and return a tuple with one entry for each binding. *) val extracts = List.map(Extract o LoadLocal) addresses val code = Newenv([RecDecs bindingsForCode], mkTuple extracts) (* Code-generate, "run" the code and extract the results. *) open Address val closure = CODE_ARRAY.makeConstantClosure() (* Turn this into a lambda to code-generate. *) val lambda:lambdaForm = { body = code, isInline = DontInline, name = "", closure = [], argTypes = [(GeneralType, [])], resultType = GeneralType, localCount = maxAddr+1, recUse = [] } val props = BACKEND.codeGenerate(lambda, debugArgs, closure) val code: unit -> machineWord = RunCall.unsafeCast closure val codeConstnt = Constnt(code(), props) fun getItem([], _) = [] | getItem(_ :: l, n) = (mkInd(n, codeConstnt), transClosure) :: getItem(l, n+1) in (* Put in the results with the closures. *) val results = getItem(bindings, 0) end in results end and processMapCode code = mapCodetree processCode code in processMapCode code end type closureRef = CODE_ARRAY.closureRef fun codeGenerate(original: lambdaForm, debugArgs, closure) = let fun toplevel _ = raise InternalError "Top level reached" val checked = checkBody(Lambda original, toplevel, toplevel, 0) val processed = case processBody(checked, toplevel, toplevel, 0, debugArgs) of Lambda p => p | _ => raise InternalError "CODETREE_LAMBDA_LIFT:codeGenerate" in BACKEND.codeGenerate(processed, debugArgs, closure) end structure Foreign = BACKEND.Foreign structure Sharing = struct open BASECODETREE.Sharing type closureRef = closureRef end end; diff --git a/mlsource/MLCompiler/CodeTree/CODETREE_OPTIMISER.sml b/mlsource/MLCompiler/CodeTree/CODETREE_OPTIMISER.sml index 3b678ac4..f70472f3 100644 --- a/mlsource/MLCompiler/CodeTree/CODETREE_OPTIMISER.sml +++ b/mlsource/MLCompiler/CodeTree/CODETREE_OPTIMISER.sml @@ -1,1415 +1,1415 @@ (* Copyright (c) 2012,13,15,17,19-20 David C.J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) functor CODETREE_OPTIMISER( structure BASECODETREE: BaseCodeTreeSig structure CODETREE_FUNCTIONS: CodetreeFunctionsSig structure REMOVE_REDUNDANT: sig type codetree type loadForm type codeUse val cleanProc : (codetree * codeUse list * (int -> loadForm) * int) -> codetree structure Sharing: sig type codetree = codetree and loadForm = loadForm and codeUse = codeUse end end structure SIMPLIFIER: sig type codetree and codeBinding and envSpecial val simplifier: { code: codetree, numLocals: int, maxInlineSize: int } -> (codetree * codeBinding list * envSpecial) * int * bool val specialToGeneral: codetree * codeBinding list * envSpecial -> codetree structure Sharing: sig type codetree = codetree and codeBinding = codeBinding and envSpecial = envSpecial end end - structure DEBUG: DEBUGSIG + structure DEBUG: DEBUG structure PRETTY : PRETTYSIG structure BACKEND: sig type codetree type machineWord = Address.machineWord val codeGenerate: codetree * int * Universal.universal list -> (unit -> machineWord) * Universal.universal list structure Sharing : sig type codetree = codetree end end sharing BASECODETREE.Sharing = CODETREE_FUNCTIONS.Sharing = REMOVE_REDUNDANT.Sharing = SIMPLIFIER.Sharing = PRETTY.Sharing = BACKEND.Sharing ) : sig type codetree and envSpecial and codeBinding val codetreeOptimiser: codetree * Universal.universal list * int -> { numLocals: int, general: codetree, bindings: codeBinding list, special: envSpecial } structure Sharing: sig type codetree = codetree and envSpecial = envSpecial and codeBinding = codeBinding end end = struct open BASECODETREE open Address open CODETREE_FUNCTIONS open StretchArray infix 9 sub exception InternalError = Misc.InternalError (* Turn a list of fields to use into a filter for SetContainer. *) fun fieldsToFilter useList = let val maxDest = List.foldl Int.max ~1 useList val fields = BoolArray.array(maxDest+1, false) val _ = List.app(fn n => BoolArray.update(fields, n, true)) useList in BoolArray.vector fields end and filterToFields filter = BoolVector.foldri (fn (i, true, l) => i :: l | (_, _, l) => l) [] filter and setInFilter filter = BoolVector.foldl (fn (true, n) => n+1 | (false, n) => n) 0 filter (* Work-around for bug in bytevector equality. *) and boolVectorEq(a, b) = filterToFields a = filterToFields b fun buildFullTuple(filter, select) = let fun extArg(t, u) = if t = BoolVector.length filter then [] else if BoolVector.sub(filter, t) then select u :: extArg(t+1, u+1) else CodeZero :: extArg (t+1, u) in mkTuple(extArg(0, 0)) end (* When transforming code we only process one level and do not descend into sub-functions. *) local fun deExtract(Extract l) = l | deExtract _ = raise Misc.InternalError "deExtract" fun onlyFunction repEntry (Lambda{ body, isInline, name, closure, argTypes, resultType, localCount, recUse }) = SOME( Lambda { body = body, isInline = isInline, name = name, closure = map (deExtract o mapCodetree repEntry o Extract) closure, argTypes = argTypes, resultType = resultType, localCount = localCount, recUse = recUse } ) | onlyFunction repEntry code = repEntry code in fun mapFunctionCode repEntry = mapCodetree (onlyFunction repEntry) end local (* This transforms the body of a "small" recursive function replacing any reference to the arguments by the appropriate entry and the recursive calls themselves by either a Loop or a recursive call. *) fun mapCodeForFunctionRewriting(code, argMap, modVec, transformCall) = let fun repEntry(Extract(LoadArgument n)) = SOME(Extract(Vector.sub(argMap, n))) | repEntry(Eval { function = Extract LoadRecursive, argList, resultType }) = let (* Filter arguments to include only those that are changed and map any values we pass. They may include references to the parameters. *) fun mapArg((arg, argT)::rest, n) = if Vector.sub(modVec, n) then mapArg(rest, n+1) else (mapCode arg, argT) :: mapArg(rest, n+1) | mapArg([], _) = [] in SOME(transformCall(mapArg(argList, 0), resultType)) end | repEntry _ = NONE and mapCode code = mapFunctionCode repEntry code in mapCode code end in (* If we have a tail recursive function we can replace the tail calls by a loop. modVec indicates the arguments that have not changed. *) fun replaceTailRecursiveWithLoop(body, argTypes, modVec, nextAddress) = let (* We need to create local bindings for arguments that will change. Those that do not can be reused. *) local fun mapArgs((argT, use):: rest, n, decs, mapList) = if Vector.sub(modVec, n) then mapArgs (rest, n+1, decs, LoadArgument n :: mapList) else let val na = ! nextAddress before nextAddress := !nextAddress + 1 in mapArgs (rest, n+1, ({addr = na, value = mkLoadArgument n, use=use}, argT) :: decs, LoadLocal na :: mapList) end | mapArgs([], _, decs, mapList) = (List.rev decs, List.rev mapList) val (decs, mapList) = mapArgs(argTypes, 0, [], []) in val argMap = Vector.fromList mapList val loopArgs = decs end in BeginLoop { arguments = loopArgs, loop = mapCodeForFunctionRewriting(body, argMap, modVec, fn (l, _) => Loop l) } end (* If we have a small recursive function where some arguments are passed through unchanged we can transform it by extracting the stable arguments and only passing the changing arguments. The advantage is that this allows the stable arguments to be inserted inline which is important if they are functions. The canonical example is List.map. *) fun liftRecursiveFunction(body, argTypes, modVec, closureSize, name, resultType, localCount) = let local fun getArgs((argType, use)::rest, nArg, clCount, argCount, stable, change, mapList) = let (* This is the argument from the outer function. It is either added to the closure or passed to the inner function. *) val argN = LoadArgument nArg in if Vector.sub(modVec, nArg) then getArgs(rest, nArg+1, clCount+1, argCount, argN :: stable, change, LoadClosure clCount :: mapList) else getArgs(rest, nArg+1, clCount, argCount+1, stable, (Extract argN, argType, use) :: change, LoadArgument argCount :: mapList) end | getArgs([], _, _, _, stable, change, mapList) = (List.rev stable, List.rev change, List.rev mapList) in (* The stable args go into the closure. The changeable args are passed in. *) val (stableArgs, changeArgsAndTypes, mapList) = getArgs(argTypes, 0, closureSize, 0, [], [], []) val argMap = Vector.fromList mapList end val subFunction = Lambda { body = mapCodeForFunctionRewriting(body, argMap, modVec, fn (l, t) => Eval { function = Extract LoadRecursive, argList = l, resultType = t }), isInline = DontInline, (* Don't inline this function. *) name = name ^ "()", closure = List.tabulate(closureSize, fn n => LoadClosure n) @ stableArgs, argTypes = List.map (fn (_, t, u) => (t, u)) changeArgsAndTypes, resultType = resultType, localCount = localCount, recUse = [UseGeneral] } in Eval { function = subFunction, argList = map (fn (c, t, _) => (c, t)) changeArgsAndTypes, resultType = resultType } end end (* If the function arguments are used in a way that could be optimised the data structure represents it. *) datatype functionArgPattern = ArgPattTuple of { filter: BoolVector.vector, allConst: bool, fromFields: bool } (* ArgPattCurry is a list, one per level of application, of a list, one per argument of the pattern for that argument. *) | ArgPattCurry of functionArgPattern list list * functionArgPattern | ArgPattSimple (* Returns ArgPattCurry even if it is just a single application. *) local (* Control how we check for side-effects. *) datatype curryControl = CurryNoCheck | CurryCheck | CurryReorderable local open Address (* Return the width of a tuple. Returns 1 for non-tuples including datatypes where different variants could have different widths. Also returns a flag indicating if the value came from a constant. Constants are already tupled so there's no advantage in untupling them unless there are other non-constant arguments as well. *) fun findTuple(Tuple{fields, isVariant=false}) = (List.length fields, false) | findTuple(Constnt(w, _)) = if isShort w orelse flags (toAddress w) <> F_words then (1, false) else (Word.toInt(length (toAddress w)), true) | findTuple(Extract _) = (1, false) (* TODO: record this for variables *) | findTuple(Cond(_, t, e)) = let val (tl, tc) = findTuple t and (el, ec) = findTuple e in if tl = el then (tl, tc andalso ec) else (1, false) end | findTuple(Newenv(_, e)) = findTuple e | findTuple _ = (1, false) in fun mapArg c = let val (n, f) = findTuple c in if n <= 1 then ArgPattSimple else ArgPattTuple{filter=BoolVector.tabulate(n, fn _ => true), allConst=f, fromFields=false} end end fun useToPattern _ [] = ArgPattSimple | useToPattern checkCurry (hd::tl) = let (* Construct a possible pattern from the head. *) val p1 = case hd of UseApply(resl, arguments) => let (* If the result is also curried extend the list. *) val subCheck = case checkCurry of CurryCheck => CurryReorderable | c => c val (resultPatts, resultResult) = case useToPattern subCheck resl of ArgPattCurry l => l | tupleOrSimple => ([], tupleOrSimple) val thisArg = map mapArg arguments in (* If we have an argument that is a curried function we can safely apply it to the first argument even if that has a side-effect but we can't uncurry further than that because the behaviour could rely on a side-effect of the first application. *) if checkCurry = CurryReorderable andalso List.exists(not o reorderable) arguments then ArgPattSimple else ArgPattCurry(thisArg :: resultPatts, resultResult) end | UseField (n, _) => ArgPattTuple{filter=BoolVector.tabulate(n+1, fn m => m=n), allConst=false, fromFields=true} | _ => ArgPattSimple fun mergePattern(ArgPattCurry(l1, r1), ArgPattCurry(l2, r2)) = let (* Each argument list should be the same length. The length here is the number of arguments provided to this application. *) fun mergeArgLists(al1, al2) = ListPair.mapEq mergePattern (al1, al2) (* The currying lists could be different lengths because some applications could only partially apply it. It is essential not to assume more currying than the minimum so we stop with the shorter. *) val prefix = ListPair.map mergeArgLists (l1, l2) in if null prefix then ArgPattSimple else ArgPattCurry(prefix, mergePattern(r1, r2)) end | mergePattern(ArgPattTuple{filter=n1, allConst=c1, fromFields=f1}, ArgPattTuple{filter=n2, allConst=c2, fromFields=f2}) = (* If the tuples are different sizes we can't use a tuple. Unlike currying it would be safe to assume tupling where there isn't (unless the function is actually polymorphic). *) if boolVectorEq(n1, n2) then ArgPattTuple{filter=n1, allConst=c1 andalso c2, fromFields = f1 andalso f2} else if f1 andalso f2 then let open BoolVector val l1 = length n1 and l2 = length n2 fun safesub(n, v) = if n < length v then v sub n else false val union = tabulate(Int.max(l1, l2), fn n => safesub(n, n1) orelse safesub(n, n2)) in ArgPattTuple{filter=union, allConst=c1 andalso c2, fromFields = f1 andalso f2} end else ArgPattSimple | mergePattern _ = ArgPattSimple in case tl of [] => p1 | tl => mergePattern(p1, useToPattern checkCurry tl) end (* If the result is just a function where all the arguments are simple it's not actually curried. *) fun usageToPattern checkCurry use = case useToPattern checkCurry use of (* a as ArgPattCurry [s] => if List.all(fn ArgPattSimple => true | _ => false) s then ArgPattSimple else a |*) patt => patt in (* Decurrying involves reordering (f exp1) exp2 into code where any effects of evaluating exp2 are done before the application. That's only safe if either (f exp1) or exp2 have no side-effects and do not depend on references. In the case of the function body we can check that the body does not depend on any references (typically it's a lambda) but for function arguments we have to check how it is applied. *) val usageForFunctionBody = usageToPattern CurryNoCheck and usageForFunctionArg = usageToPattern CurryCheck (* To decide whether we want to detuple the argument we look to see if the function is ever applied to a tuple. This is rather different to currying where we only decurry if every application is to multiple arguments. This information is then merged with information about the arguments within the function. *) fun existTupling (use: codeUse list): functionArgPattern list = let val argListLists = List.foldl (fn (UseApply(_, args), l) => map mapArg args :: l | (_, l) => l) [] use fun orMerge [] = raise Empty | orMerge [hd] = hd | orMerge (hd1 :: hd2 :: tl) = let fun merge(a as ArgPattTuple _, _) = a | merge(_, b) = b in orMerge(ListPair.mapEq merge (hd1, hd2) :: tl) end in orMerge argListLists end (* If the result of a function contains a tuple but it is not detupled on every path, see if it is detupled on at least one. *) fun existDetupling(UseApply(resl, _) :: rest) = List.exists(fn UseField _ => true | _ => false) resl orelse existDetupling rest | existDetupling(_ :: rest) = existDetupling rest | existDetupling [] = false end (* Return a tuple if any of the branches returns a tuple. The idea is that if the body actually constructs a tuple on the heap on at least one branch it is probably worth attempting to detuple the result. *) fun bodyReturnsTuple (Tuple{fields, isVariant=false}) = ArgPattTuple{ filter=BoolVector.tabulate(List.length fields, fn _ => true), allConst=false, fromFields=false } | bodyReturnsTuple(Cond(_, t, e)) = ( case bodyReturnsTuple t of a as ArgPattTuple _ => a | _ => bodyReturnsTuple e ) | bodyReturnsTuple(Newenv(_, exp)) = bodyReturnsTuple exp | bodyReturnsTuple _ = ArgPattSimple (* If the usage indicates that the body of the function should be transformed these do the transformation. It is possible that each of these cases could apply and it would be possible to merge them all. For the moment keep them separate. If another of the cases applies this will be re-entered on a subsequent pass. *) fun detupleResult({ argTypes, name, resultType, closure, isInline, localCount, body, ...}: lambdaForm , filter, makeAddress) = (* The function returns a tuple or at least the uses of the function take apart a tuple. Transform it to take a container as an argument and put the result in there. *) let local fun mapArg f n ((t, _) :: tl) = (Extract(f n), t) :: mapArg f (n+1) tl | mapArg _ _ [] = [] in fun mapArgs f l = mapArg f 0 l end val mainAddress = makeAddress() and shimAddress = makeAddress() (* The main function performs the previous computation but puts the result into the container. We need to replace any recursive references with calls to the shim.*) local val recEntry = LoadClosure(List.length closure) fun doMap(Extract LoadRecursive) = SOME(Extract recEntry) | doMap _ = NONE in val transBody = mapFunctionCode doMap body end local val containerArg = Extract(LoadArgument(List.length argTypes)) val newBody = SetContainer{container = containerArg, tuple = transBody, filter=filter } val mainLambda: lambdaForm = { body = newBody, name = name, resultType=GeneralType, argTypes=argTypes @ [(GeneralType, [])], closure=closure @ [LoadLocal shimAddress], localCount=localCount + 1, isInline=isInline, recUse = [UseGeneral] } in val mainFunction = (mainAddress, mainLambda) end (* The shim function creates a container, passes it to the main function and then builds a tuple from the container. *) val shimBody = mkEnv( [Container{addr = 0, use = [], size = setInFilter filter, setter= Eval { function = Extract(LoadClosure 0), argList = mapArgs LoadArgument argTypes @ [(Extract(LoadLocal 0), GeneralType)], resultType = GeneralType } } ], buildFullTuple(filter, fn n => mkIndContainer(n, mkLoadLocal 0)) ) val shimLambda = { body = shimBody, name = name, argTypes = argTypes, closure = [LoadLocal mainAddress], resultType = resultType, isInline = InlineAlways, localCount = 1, recUse = [UseGeneral] } val shimFunction = (shimAddress, shimLambda) in (shimLambda, [mainFunction, shimFunction]) end fun transformFunctionArgs({ argTypes, name, resultType, closure, isInline, localCount, body, ...} , usage, makeAddress) = (* Not curried - just a single argument. *) let (* We need to construct an inline "shim" function that has the same calling pattern as the original. This simply calls the transformed main function. We need to construct the arguments to call the transformed main function. That needs, for example, to unpack tuples and repack argument functions. We need to produce an argument map to transform the main function. This needs, for example, to pack the arguments into tuples. Then when the code is run through the simplifier the tuples will be optimised away. *) val localCounter = ref localCount fun mapPattern(ArgPattTuple{filter, allConst=false, ...} :: patts, n, m) = let val fieldList = filterToFields filter val (decs, args, mapList) = mapPattern(patts, n+1, m + setInFilter filter) val newAddr = ! localCounter before localCounter := ! localCounter + 1 val tuple = buildFullTuple(filter, fn u => mkLoadArgument(m+u)) val thisDec = Declar { addr = newAddr, use = [], value = tuple } (* Arguments for the call *) val thisArg = List.map(fn p => mkInd(p, mkLoadArgument n)) fieldList in (thisDec :: decs, thisArg @ args, LoadLocal newAddr :: mapList) end | mapPattern(ArgPattCurry(currying as [_], ArgPattTuple{allConst=false, filter, ...}) :: patts, n, m) = (* It's a function that returns a tuple. The function must not be curried because otherwise it returns a function not a tuple. *) let val (thisDec, thisArg, thisMap) = transformFunctionArgument(currying, [LoadArgument m], [LoadArgument n], SOME filter) val (decs, args, mapList) = mapPattern(patts, n+1, m+1) in (thisDec :: decs, thisArg :: args, thisMap :: mapList) end | mapPattern(ArgPattCurry(currying as firstArgSet :: _, _) :: patts, n, m) = (* Transform it if it's curried or if there is a tuple in the first arg. *) if (*List.length currying >= 2 orelse *) (* This transformation is unsafe. *) List.exists(fn ArgPattTuple{allConst=false, ...} => true | _ => false) firstArgSet then let val (thisDec, thisArg, thisMap) = transformFunctionArgument(currying, [LoadArgument m], [LoadArgument n], NONE) val (decs, args, mapList) = mapPattern(patts, n+1, m+1) in (thisDec :: decs, thisArg :: args, thisMap :: mapList) end else let val (decs, args, mapList) = mapPattern(patts, n+1, m+1) in (decs, Extract(LoadArgument n) :: args, LoadArgument m :: mapList) end | mapPattern(_ :: patts, n, m) = let val (decs, args, mapList) = mapPattern(patts, n+1, m+1) in (decs, Extract(LoadArgument n) :: args, LoadArgument m :: mapList) end | mapPattern([], _, _) = ([], [], []) and transformFunctionArgument(argumentArgs, loadPack, loadThisArg, filterOpt) = let (* Disable the transformation of curried arguments for the moment. This is unsafe. See Test146. The problem is that this transformation is only safe if the function is applied immediately to all the arguments. However the usage information is propagated so that if the result of the first application is bound to a variable and then that variable is applied it still appears as curried. *) val argumentArgs = [hd argumentArgs] (* We have a function that takes a series of curried argument. Change that so that the function takes a list of arguments. *) val newAddr = ! localCounter before localCounter := ! localCounter + 1 (* In the main function we are expecting to call the argument in a curried fashion. We need to construct a function that packages up the arguments and, when all of them have been provided, calls the actual argument. *) local fun curryPack([], fnclosure) = let (* We're ready to call the function. We now need to unpack any tupled arguments. *) fun mapArgs(c :: ctl, args) = let fun mapArg([], args) = mapArgs(ctl, args) | mapArg(ArgPattTuple{filter, allConst=false, ...} :: patts, arg :: argctl) = let val fields = filterToFields filter in List.map(fn p => (mkInd(p, Extract arg), GeneralType)) fields @ mapArg(patts, argctl) end | mapArg(_ :: patts, arg :: argctl) = (Extract arg, GeneralType) :: mapArg(patts, argctl) | mapArg(_, []) = raise InternalError "mapArgs: mismatch" in mapArg(c, args) end | mapArgs _ = [] val argList = mapArgs(argumentArgs, tl fnclosure) in case filterOpt of NONE => Eval { function = Extract(hd fnclosure), resultType = GeneralType, argList = argList } | SOME filter => (* We need a container here for the result. *) mkEnv( [ Container{addr=0, size=setInFilter filter, use=[UseGeneral], setter= Eval { function = Extract(hd fnclosure), resultType = GeneralType, argList = argList @ [(mkLoadLocal 0, GeneralType)] } } ], buildFullTuple(filter, fn n => mkIndContainer(n, mkLoadLocal 0)) ) end | curryPack(hd :: tl, fnclosure) = let val nArgs = List.length hd (* If this is the last then we need to include the container if required. *) val needContainer = case (tl, filterOpt) of ([], SOME _) => true | _ => false in Lambda { closure = fnclosure, isInline = InlineAlways, name = name ^ "-P", resultType = GeneralType, argTypes = List.tabulate(nArgs, fn _ => (GeneralType, [UseGeneral])), localCount = if needContainer then 1 else 0, recUse = [], body = curryPack(tl, (* The closure for the next level is the current closure together with all the arguments at this level. *) List.tabulate(List.length fnclosure, fn n => LoadClosure n) @ List.tabulate(nArgs, LoadArgument)) } end in val packFn = curryPack(argumentArgs, loadPack) end val thisDec = Declar { addr = newAddr, use = [], value = packFn } fun argCount(ArgPattTuple{filter, allConst=false, ...}, m) = setInFilter filter + m | argCount(_, m) = m+1 local (* In the shim function, i.e. the inline function outside, we have a lambda that will be called when the main function wants to call its argument function. This is provided with all the arguments and so it has to call the actual argument, which is expected to be curried, an argument at a time. *) fun curryApply(hd :: tl, n, c) = let fun makeArgs(_, []) = [] | makeArgs(q, ArgPattTuple{filter, allConst=false, ...} :: args) = (buildFullTuple(filter, fn r => mkLoadArgument(r+q)), GeneralType) :: makeArgs(q + setInFilter filter, args) | makeArgs(q, _ :: args) = (mkLoadArgument q, GeneralType) :: makeArgs(q+1, args) val args = makeArgs(n, hd) in curryApply(tl, n + List.foldl argCount 0 hd, Eval{function=c, resultType = GeneralType, argList=args}) end | curryApply([], _, c) = c in val thisBody = curryApply (argumentArgs, 0, mkLoadClosure 0) end local (* We have one argument for each argument at each level of currying, or where we've expanded a tuple, one argument for each field. If the function is returning a tuple we have an extra argument for the container. *) val totalArgCount = List.foldl(fn (c, n) => n + List.foldl argCount 0 c) 0 argumentArgs + (case filterOpt of SOME _ => 1 | _ => 0) val functionBody = case filterOpt of NONE => thisBody | SOME filter => mkSetContainer(mkLoadArgument(totalArgCount-1), thisBody, filter) in val thisArg = Lambda { closure = loadThisArg, isInline = InlineAlways, name = name ^ "-E", argTypes = List.tabulate(totalArgCount, fn _ => (GeneralType, [UseGeneral])), resultType = GeneralType, localCount = 0, recUse = [UseGeneral], body = functionBody } end in (thisDec, thisArg, LoadLocal newAddr) end val (extraBindings, transArgCode, argMapList) = mapPattern(usage, 0, 0) local (* Transform the body by replacing the arguments with the new arguments. *) val argMap = Vector.fromList argMapList (* If we have a recursive reference we have to replace it with a reference to the shim. *) val recEntry = LoadClosure(List.length closure) fun doMap(Extract(LoadArgument n)) = SOME(Extract(Vector.sub(argMap, n))) | doMap(Extract LoadRecursive) = SOME(Extract recEntry) | doMap _ = NONE in val transBody = mapFunctionCode doMap body end local (* The argument types for the main function have the tuples expanded, Functions are not affected. *) fun expand(ArgPattTuple{filter, allConst=false, ...}, _, r) = List.tabulate(setInFilter filter, fn _ => (GeneralType, [])) @ r | expand(_, a, r) = a :: r in val transArgTypes = ListPair.foldrEq expand [] (usage, argTypes) end (* Add the type information to the argument code. *) val transArgs = ListPair.mapEq(fn (c, (t, _)) => (c, t)) (transArgCode, transArgTypes) val mainAddress = makeAddress() and shimAddress = makeAddress() val transLambda = { body = mkEnv(extraBindings, transBody), name = name, argTypes = transArgTypes, closure = closure @ [LoadLocal shimAddress], resultType = resultType, isInline = isInline, localCount = ! localCounter, recUse = [UseGeneral] } (* Return the pair of functions. *) val mainFunction = (mainAddress, transLambda) val shimBody = Eval { function = Extract(LoadClosure 0), argList = transArgs, resultType = resultType } val shimLambda = { body = shimBody, name = name, argTypes = argTypes, closure = [LoadLocal mainAddress], resultType = resultType, isInline = InlineAlways, localCount = 0, recUse = [UseGeneral] } val shimFunction = (shimAddress, shimLambda) (* TODO: We have two copies of the shim function here. *) in (shimLambda, [mainFunction, shimFunction]) end fun decurryFunction( { argTypes, name, resultType, closure, isInline, localCount, body as Lambda { argTypes=subArgTypes, resultType=subResultType, ... } , ...}, makeAddress) = (* Curried - just unwind one level this time. This case is normally dealt with by the front-end at least for fun bindings. *) let local fun mapArg f n ((t, _) :: tl) = (Extract(f n), t) :: mapArg f (n+1) tl | mapArg _ _ [] = [] in fun mapArgs f l = mapArg f 0 l end val mainAddress = makeAddress() and shimAddress = makeAddress() (* The main function calls the original body as a function. The body is a lambda which will contain references to the outer arguments but because we're just adding arguments these will be as before. *) (* We have to transform any recursive references to point to the shim. *) local val recEntry = LoadClosure(List.length closure) fun doMap(Extract LoadRecursive) = SOME(Extract recEntry) | doMap _ = NONE in val transBody = mapFunctionCode doMap body end val arg1Count = List.length argTypes val mainLambda = { body = Eval{ function = transBody, resultType = subResultType, argList = mapArgs (fn n => LoadArgument(n+arg1Count)) subArgTypes }, name = name, resultType = subResultType, closure = closure @ [LoadLocal shimAddress], isInline = isInline, localCount = localCount, argTypes = argTypes @ subArgTypes, recUse = [UseGeneral] } val mainFunction = (mainAddress, mainLambda) val shimInnerLambda = Lambda { (* The inner shim closure contains the main function and the outer arguments. *) closure = LoadClosure 0 :: List.tabulate(arg1Count, LoadArgument), body = Eval { function = Extract(LoadClosure 0), resultType = resultType, (* Calls main function with both sets of args. *) argList = mapArgs (fn n => LoadClosure(n+1)) argTypes @ mapArgs LoadArgument subArgTypes }, name = name ^ "-", resultType = subResultType, localCount = 0, isInline = InlineAlways, argTypes = subArgTypes, recUse = [UseGeneral] } val shimOuterLambda = { body = shimInnerLambda, name = name, argTypes = argTypes, closure = [LoadLocal mainAddress], resultType = resultType, isInline = InlineAlways, localCount = 0, recUse = [UseGeneral] } val shimFunction = (shimAddress, shimOuterLambda) in (shimOuterLambda: lambdaForm, [mainFunction, shimFunction]) end | decurryFunction _ = raise InternalError "decurryFunction" (* Process a Lambda slightly differently in different contexts. *) datatype lambdaContext = LCNormal | LCRecursive | LCImmediateCall (* Transforming a lambda may result in producing auxiliary functions that are in general mutually recursive. *) fun mapLambdaResult([], lambda) = lambda | mapLambdaResult(bindings, lambda) = mkEnv([RecDecs(map(fn(addr, lam) => {addr=addr, use=[], lambda=lam}) bindings)], lambda) fun optimise (context, use) (Lambda lambda) = SOME(mapLambdaResult(optLambda(context, use, lambda, LCNormal))) | optimise (context, use) (Newenv(envDecs, envExp)) = let fun mapExp mapUse = mapCodetree (optimise(context, mapUse)) fun mapbinding(Declar{value, addr, use}) = Declar{value=mapExp use value, addr=addr, use=use} | mapbinding(RecDecs l) = let fun mapRecDec({addr, lambda, use}, rest) = case optLambda(context, use, lambda, LCRecursive) of (bindings, Lambda lambdaRes) => (* Turn any bindings into extra mutually-recursive functions. *) {addr=addr, use = use, lambda = lambdaRes } :: map (fn (addr, res) => {addr=addr, use=use, lambda=res }) bindings @ rest | _ => raise InternalError "mapbinding: not lambda" in RecDecs(foldl mapRecDec [] l) end | mapbinding(NullBinding exp) = NullBinding(mapExp [UseGeneral] exp) | mapbinding(Container{addr, use, size, setter}) = Container{addr=addr, use=use, size=size, setter = mapExp [UseGeneral] setter} in SOME(Newenv(map mapbinding envDecs, mapExp use envExp)) end (* Immediate call to a function. We may be able to expand this inline unless it is recursive. *) | optimise (context, use) (Eval {function = Lambda lambda, argList, resultType}) = let val args = map (fn (c, t) => (optGeneral context c, t)) argList val argTuples = map #1 args val (bindings, newLambda) = optLambda(context, [UseApply(use, argTuples)], lambda, LCImmediateCall) val call = Eval { function=newLambda, argList=args, resultType = resultType } in SOME(mapLambdaResult(bindings, call)) end | optimise (context as { reprocess, ...}, use) (Eval {function = Cond(i, t, e), argList, resultType}) = let (* Transform "(if i then t else e) x" into "if i then t x else e x". This allows for other optimisations and inline expansion. *) (* We duplicate the function arguments which could cause the size of the code to blow-up if they involve complicated expressions. *) fun pushFunction l = mapCodetree (optimise(context, use)) (Eval{function=l, argList=argList, resultType=resultType}) in reprocess := true; SOME(Cond(i, pushFunction t, pushFunction e)) end | optimise (context, use) (Eval {function, argList, resultType}) = (* If nothing else we need to ensure that "use" is correctly set on the function and arguments and we don't simply pass the original. *) let val args = map (fn (c, t) => (optGeneral context c, t)) argList val argTuples = map #1 args in SOME( Eval{ function= mapCodetree (optimise (context, [UseApply(use, argTuples)])) function, argList=args, resultType = resultType }) end | optimise (context, use) (Indirect{base, offset, indKind = IndTuple}) = SOME(Indirect{base = mapCodetree (optimise(context, [UseField(offset, use)])) base, offset = offset, indKind = IndTuple}) | optimise (context, use) (code as Cond _) = (* If the result of the if-then-else is always taken apart as fields then we are better off taking it apart further down and putting the fields into a container on the stack. *) if List.all(fn UseField _ => true | _ => false) use then SOME(optFields(code, context, use)) else NONE | optimise (context, use) (code as BeginLoop _) = (* If the result of the loop is taken apart we should push this down as well. *) if List.all(fn UseField _ => true | _ => false) use then SOME(optFields(code, context, use)) else NONE | optimise _ _ = NONE and optGeneral context exp = mapCodetree (optimise(context, [UseGeneral])) exp and optLambda( { maxInlineSize, reprocess, makeAddr, ... }, contextUse, { body, name, argTypes, resultType, closure, localCount, isInline, recUse, ...}, lambdaContext) : (int * lambdaForm) list * codetree = (* Optimisations on lambdas. 1. A lambda that simply calls another function with all its own arguments can be replaced by a reference to the function provided the "function" is a side-effect-free expression. 2. Don't attempt to optimise inline functions that are exported. 3. Transform lambdas that take tuples as arguments or are curried or where an argument is a function with tupled or curried arguments into a pair of an inline function with the original argument set and a new "main" function with register/stack arguments. *) let (* The overall use of the function is the context plus the recursive use. *) val use = contextUse @ recUse (* Check if it's a call to another function with all the original arguments. This is really wanted when we are passing this lambda as an argument to another function and really only when we have produced a shim function that has been inline expanded. Otherwise this will be a "small" function and will be inline expanded when it's used. *) val replaceBody = case (body, lambdaContext = LCRecursive) of (Eval { function, argList, resultType=callresult }, false) => let fun argSequence((Extract(LoadArgument a), _) :: rest, b) = a = b andalso argSequence(rest, b+1) | argSequence([], _) = true | argSequence _ = false val argumentsMatch = argSequence(argList, 0) andalso ListPair.allEq(fn((_, a), (b, _)) => a = b) (argList, argTypes) andalso callresult = resultType in if not argumentsMatch then NONE else case function of (* This could be any function which has neither side-effects nor depends on a reference nor depends on another argument but if it has local variables they would have to be renumbered into the surrounding scope. In practice we're really only interested in simple cases that arise as a result of using a "shim" function created in the code below. *) c as Constnt _ => SOME c | Extract(LoadClosure addr) => SOME(Extract(List.nth(closure, addr))) | _ => NONE end | _ => NONE in case replaceBody of SOME c => ([], c) | NONE => if isInline <> DontInline andalso List.exists (fn UseExport => true | _ => false) use then let (* If it's inline any application of this will be optimised after inline expansion. We still apply any opimisations to the body at this stage because we will compile and code-generate a version for use if we want a "general" value. *) val addressAllocator = ref localCount val optContext = { makeAddr = fn () => (! addressAllocator) before addressAllocator := ! addressAllocator + 1, reprocess = reprocess, maxInlineSize = maxInlineSize } val optBody = mapCodetree (optimise(optContext, [UseGeneral])) body val lambdaRes = { body = optBody, isInline = isInline, name = name, closure = closure, argTypes = argTypes, resultType = resultType, recUse = recUse, localCount = !addressAllocator (* After optimising body. *) } in ([], Lambda lambdaRes) end else let (* Allocate any new addresses after the existing ones. *) val addressAllocator = ref localCount val optContext = { makeAddr = fn () => (! addressAllocator) before addressAllocator := ! addressAllocator + 1, reprocess = reprocess, maxInlineSize = maxInlineSize } val optBody = mapCodetree (optimise(optContext, [UseGeneral])) body (* See if this should be expanded inline. If we are calling the lambda immediately we try to expand it unless maxInlineSize is zero. We may not be able to expand it if it is recursive. (It may have been inside an inline function). *) val (inlineType, updatedBody, localCount) = case evaluateInlining(optBody, List.length argTypes, if maxInlineSize <> 0 andalso lambdaContext = LCImmediateCall then 1000 else FixedInt.toInt maxInlineSize) of NonRecursive => (SmallInline, optBody, ! addressAllocator) | TailRecursive bv => (SmallInline, replaceTailRecursiveWithLoop(optBody, argTypes, bv, addressAllocator), ! addressAllocator) | NonTailRecursive bv => if Vector.exists (fn n => n) bv then (SmallInline, liftRecursiveFunction( optBody, argTypes, bv, List.length closure, name, resultType, !addressAllocator), 0) else (DontInline, optBody, ! addressAllocator) (* All arguments have been modified *) | TooBig => (DontInline, optBody, ! addressAllocator) val lambda: lambdaForm = { body = updatedBody, name = name, argTypes = argTypes, closure = closure, resultType = resultType, isInline = inlineType, localCount = localCount, recUse = recUse } (* See if it should be transformed. We only do this if the function is not going to be inlined. If it is then there's no point because the transformation is going to be done as part of the inling process. Even if it's marked for inlining we may not actually call the function and instead pass it as an argument or return it as result but in that case transformation doesn't achieve anything because we are going to pass the untransformed "shim" function anyway. *) val (newLambda, bindings) = if isInline = DontInline then let val functionPattern = case usageForFunctionBody use of ArgPattCurry(arg1 :: arg2 :: moreArgs, res) => (* The function is always called with at least two curried arguments. We can decurry the function if the body is applicative - typically if it's a lambda - but not if applying the body would have a side-effect. We only do it one level at this stage. If it's curried more than that we'll come here again. *) (* In order to get the types we restrict this to the case of a body that is a lambda. The result is a function and therefore ArgPattSimple unless we are using up all the args. *) if (*reorderable body*) case updatedBody of Lambda _ => true | _ => false then ArgPattCurry([arg1, arg2], if null moreArgs then res else ArgPattSimple) else ArgPattCurry([arg1], ArgPattSimple) | usage => usage val argPatterns = map (usageForFunctionArg o #2) argTypes (* fullArgPattern is a list, one per level of currying, of a list, one per argument of the patterns. resultPattern is used to detect whether the result is a tuple that is taken apart. *) val (fullArgPattern, resultPattern) = case functionPattern of ArgPattCurry(_ :: rest, resPattern) => let (* The function is always applied at least to the first set of arguments. (It's never just passed). Merge the applications of the function with the use of the arguments. Return the usage within the function unless the function takes apart a tuple but no application passes in a tuple. *) fun merge(ArgPattTuple _, argUse as ArgPattTuple _) = argUse | merge(_, ArgPattTuple _) = ArgPattSimple | merge(_, argUse) = argUse val mergedArgs = (ListPair.mapEq merge (existTupling use, argPatterns)) :: rest (* *) val mergedResult = case (bodyReturnsTuple updatedBody, resPattern) of (bodyTuple as ArgPattTuple _, ArgPattSimple) => if existDetupling use then bodyTuple else ArgPattSimple | _ => resPattern in (mergedArgs, mergedResult) end | _ => (* Not called: either exported or passed as a value. *) (* This previously tried to see whether the body returned a tuple if the function was exported. This caused an infinite loop (see Tests/Succeed/Test164.ML) and anyway doesn't seem to optimise the cases we want. *) ([], ArgPattSimple) in case (fullArgPattern, resultPattern) of (_ :: _ :: _, _) => (* Curried *) ( reprocess := true; decurryFunction(lambda, makeAddr)) | (_, ArgPattTuple {filter, ...}) => (* Result is a tuple *) ( reprocess := true; detupleResult(lambda, filter, makeAddr)) | (first :: _, _) => let fun checkArg (ArgPattTuple{allConst=false, ...}) = true (* Function has at least one tupled arg. *) | checkArg (ArgPattCurry([_], ArgPattTuple{allConst=false, ...})) = true (* Function has an arg that is a function that returns a tuple. It must not be curried otherwise it returns a function not a tuple. *) (* This transformation is unsafe. See comment in transformFunctionArgument above. *) (*| checkArg (ArgPattCurry(_ :: _ :: _, _)) = true *) (* Function has an arg that is a curried function. *) | checkArg (ArgPattCurry(firstArgSet :: _, _)) = (* Function has an arg that is a function that takes a tuple in its first argument set. *) List.exists(fn ArgPattTuple{allConst=false, ...} => true | _ => false) firstArgSet | checkArg _ = false in (* It isn't curried - look at the arguments. *) if List.exists checkArg first then ( reprocess := true; transformFunctionArgs(lambda, first, makeAddr) ) else (lambda, []) end | _ => (lambda, []) end else (lambda, []) in (* If this is to be inlined but was not before we may need to reprocess. We don't reprocess if this is only exported. If it's only exported we're not going to expand it within this code and we can end up with repeated processing. *) if #isInline newLambda <> DontInline andalso isInline = DontInline andalso (case use of [UseExport] => false | _ => true) then reprocess := true else (); (bindings, Lambda newLambda) end end and optFields (code, context as { reprocess, makeAddr, ...}, use) = let (* We have an if-then-else or a loop whose result is only ever taken apart. We push this down. *) (* Find the fields that are used. Not all may be. *) local val maxField = List.foldl(fn (UseField(f, _), m) => Int.max(f, m) | (_, m) => m) 0 use val fieldUse = BoolArray.array(maxField+1, false) val _ = List.app(fn UseField(f, _) => BoolArray.update(fieldUse, f, true) | _ => ()) use in val maxField = maxField val useList = BoolArray.foldri (fn (i, true, l) => i :: l | (_, _, l) => l) [] fieldUse end fun pushContainer(Cond(ifpt, thenpt, elsept), leafFn) = Cond(ifpt, pushContainer(thenpt, leafFn), pushContainer(elsept, leafFn)) | pushContainer(Newenv(decs, exp), leafFn) = Newenv(decs, pushContainer(exp, leafFn)) | pushContainer(BeginLoop{loop, arguments}, leafFn) = (* If we push it through a BeginLoop we MUST then push it through anything that could contain the Loop i.e. Cond, Newenv, Handle. *) BeginLoop{loop = pushContainer(loop, leafFn), arguments=arguments} | pushContainer(l as Loop _, _) = l (* Within a BeginLoop only the non-Loop leaves return values. Loop entries go back to the BeginLoop so these are unchanged. *) | pushContainer(Handle{exp, handler, exPacketAddr}, leafFn) = Handle{exp=pushContainer(exp, leafFn), handler=pushContainer(handler, leafFn), exPacketAddr=exPacketAddr} | pushContainer(tuple, leafFn) = leafFn tuple (* Anything else. *) val () = reprocess := true in case useList of [offset] => (* We only want a single field. Push down an Indirect. *) let (* However the context still requires a tuple. We need to reconstruct one with unused fields set to zero. They will be filtered out later by the simplifier pass. *) val field = optGeneral context (pushContainer(code, fn t => mkInd(offset, t))) fun mkFields n = if n = offset then field else CodeZero in Tuple{ fields = List.tabulate(offset+1, mkFields), isVariant = false } end | _ => let (* We require a container. *) val containerAddr = makeAddr() val width = List.length useList val loadContainer = Extract(LoadLocal containerAddr) fun setContainer tuple = (* At the leaf set the container. *) SetContainer{container = loadContainer, tuple = tuple, filter = fieldsToFilter useList } val setCode = optGeneral context (pushContainer(code, setContainer)) val makeContainer = Container{addr=containerAddr, use=[], size=width, setter=setCode} (* The context requires a tuple of the original width. We need to add dummy fields where necessary. *) val container = if width = maxField+1 then mkTupleFromContainer(containerAddr, width) else let fun mkField(n, m, hd::tl) = if n = hd then mkIndContainer(m, loadContainer) :: mkField(n+1, m+1, tl) else CodeZero :: mkField(n+1, m, hd::tl) | mkField _ = [] in Tuple{fields = mkField(0, 0, useList), isVariant=false} end in mkEnv([makeContainer], container) end end (* TODO: convert "(if a then b else c) (args)" into if a then b(args) else c(args). This would allow for possible inlining and also passing information about call patterns. *) (* Once all the inlining is done we look for functions that can be compiled immediately. These are either functions with no free variables or functions where every use is a call, as opposed to being passed or returned as a closure. Functions that have free variables but are called can be lambda-lifted where the free variables are turned into extra parameters. The advantage compared with using a static-link or a closure on the stack is that they can be fully tail-recursive. With a static-link or stack closure the free variables have to remain on the stack until the function returns. *) fun lambdaLiftAndConstantFunction(code, debugSwitches, numLocals) = let val needReprocess = ref false (* At the moment this just code-generates immediately any lambdas without free-variables. The idea is to that we will get a constant which can then be inserted directly in references to the function. In general this takes a list of mutually recursive functions which can be code- generated immediately if all the free variables are other functions in the list. The simplifier has separated mutually recursive bindings into strongly connected components so we can consider the list as a single entity. *) fun processLambdas lambdaList = let (* First process the bodies of the functions. *) val needed = ! needReprocess val _ = needReprocess := false; val transLambdas = map (fn {lambda={body, isInline, name, closure, argTypes, resultType, localCount, recUse}, use, addr} => {lambda={body=mapChecks body, isInline=isInline, name=name, closure=closure, argTypes=argTypes, resultType=resultType, localCount=localCount, recUse=recUse}, use=use, addr=addr}) lambdaList val theseTransformed = ! needReprocess val _ = if needed then needReprocess := true else () fun hasFreeVariables{lambda={closure, ...}, ...} = let fun notInLambdas(LoadLocal lAddr) = (* A local is allowed if it only refers to another lambda. *) not (List.exists (fn {addr, ...} => addr = lAddr) lambdaList) | notInLambdas _ = true (* Anything else is not allowed. *) in List.exists notInLambdas closure end in if theseTransformed orelse List.exists (fn {lambda={isInline, ...}, ...} => isInline <> DontInline) lambdaList orelse List.exists hasFreeVariables lambdaList (* If we have transformed any of the bodies we need to reprocess so defer any code-generation. Don't CG it if it is inline, or perhaps if it is inline and exported. Don't CG it if it has free variables. We still need to examine the bodies of the functions. *) then (transLambdas, []) else let (* Construct code to declare the functions and extract the values. *) val tupleFields = map (fn {addr, ...} => Extract(LoadLocal addr)) transLambdas val decsAndTuple = Newenv([RecDecs transLambdas], mkTuple tupleFields) val maxLocals = List.foldl(fn ({addr, ...}, n) => Int.max(addr, n)) 0 transLambdas val (code, props) = BACKEND.codeGenerate(decsAndTuple, maxLocals + 1, debugSwitches) val resultConstnt = Constnt(code(), props) fun getResults([], _) = [] | getResults({addr, use, ...} :: tail, n) = Declar {value=mkInd(n, resultConstnt), addr=addr, use=use} :: getResults(tail, n+1) val () = needReprocess := true in ([], getResults(transLambdas, 0)) end end and runChecks (Lambda (lambda as { isInline=DontInline, closure=[], ... })) = ( (* Bare lambda. *) case processLambdas[{lambda=lambda, use = [], addr = 0}] of ([{lambda=unCGed, ...}], []) => SOME(Lambda unCGed) | ([], [Declar{value, ...}]) => SOME value | _ => raise InternalError "processLambdas" ) | runChecks (Newenv(bindings, exp)) = let (* We have a block of bindings. Are any of them functions that are only ever called? *) fun checkBindings(Declar{value=Lambda lambda, addr, use}, tail) = ( (* Process this lambda and extract the result. *) case processLambdas[{lambda=lambda, use = use, addr = addr}] of ([{lambda=unCGed, use, addr}], []) => Declar{value=Lambda unCGed, use=use, addr=addr} :: tail | ([], cgedDec) => cgedDec @ tail | _ => raise InternalError "checkBindings" ) | checkBindings(Declar{value, addr, use}, tail) = Declar{value=mapChecks value, addr=addr, use=use} :: tail | checkBindings(RecDecs l, tail) = let val (notConsts, asConsts) = processLambdas l in asConsts @ (if null notConsts then [] else [RecDecs notConsts]) @ tail end | checkBindings(NullBinding exp, tail) = NullBinding(mapChecks exp) :: tail | checkBindings(Container{addr, use, size, setter}, tail) = Container{addr=addr, use=use, size=size, setter=mapChecks setter} :: tail in SOME(Newenv((List.foldr checkBindings [] bindings), mapChecks exp)) end | runChecks _ = NONE and mapChecks c = mapCodetree runChecks c in (mapCodetree runChecks code, numLocals, !needReprocess) end (* Main optimiser and simplifier loop. *) fun codetreeOptimiser(code, debugSwitches, numLocals) = let fun topLevel _ = raise InternalError "top level reached in optimiser" val maxInlineSize = DEBUG.getParameter DEBUG.maxInlineSizeTag debugSwitches fun processTree (code, nLocals, optAgain) = let (* First run the simplifier. Among other things this does inline expansion and if it does any we at least need to run cleanProc on the code so it will have set simpAgain. *) val (simpCode, simpCount, simpAgain) = SIMPLIFIER.simplifier{code=code, numLocals=nLocals, maxInlineSize=FixedInt.toInt maxInlineSize} in if optAgain orelse simpAgain then let (* Identify usage information and remove redundant code. *) val printCodeTree = DEBUG.getParameter DEBUG.codetreeTag debugSwitches and compilerOut = PRETTY.getCompilerOutput debugSwitches val simpCode = SIMPLIFIER.specialToGeneral simpCode val () = if printCodeTree then compilerOut(PRETTY.PrettyString "Output of simplifier") else () val () = if printCodeTree then compilerOut (BASECODETREE.pretty simpCode) else () val preOptCode = REMOVE_REDUNDANT.cleanProc(simpCode, [UseExport], topLevel, simpCount) (* Print the code with the use information before it goes into the optimiser. *) val () = if printCodeTree then compilerOut(PRETTY.PrettyString "Output of cleaner") else () val () = if printCodeTree then compilerOut (BASECODETREE.pretty preOptCode) else () val reprocess = ref false (* May be set in the optimiser *) (* Allocate any new addresses after the existing ones. *) val addressAllocator = ref simpCount fun makeAddr() = (! addressAllocator) before addressAllocator := ! addressAllocator + 1 val optContext = { makeAddr = makeAddr, reprocess = reprocess, maxInlineSize = maxInlineSize } (* Optimise the code, rewriting it as necessary. *) val optCode = mapCodetree (optimise(optContext, [UseExport])) preOptCode val (llCode, llCount, llAgain) = (* If we have optimised it or the simplifier has run something that it wants to run again we must rerun these before we try to generate any code. *) if ! reprocess (* Re-optimise *) orelse simpAgain (* The simplifier wants to run again on this. *) then (optCode, ! addressAllocator, ! reprocess) else (* We didn't detect any inlineable functions. Check for lambda-lifting. *) lambdaLiftAndConstantFunction(optCode, debugSwitches, ! addressAllocator) (* Print the code after the optimiser. *) val () = if printCodeTree then compilerOut(PRETTY.PrettyString "Output of optimiser") else () val () = if printCodeTree then compilerOut (BASECODETREE.pretty llCode) else () in (* Rerun the simplifier at least. *) processTree(llCode, llCount, llAgain) end else (simpCode, simpCount) (* We're done *) end val (postOptCode, postOptCount) = processTree(code, numLocals, true (* Once at least *)) val (rGeneral, rDecs, rSpec) = postOptCode in { numLocals = postOptCount, general = rGeneral, bindings = rDecs, special = rSpec } end structure Sharing = struct type codetree = codetree and envSpecial = envSpecial and codeBinding = codeBinding end end; diff --git a/mlsource/MLCompiler/CodeTree/CODETREE_SIMPLIFIER.sml b/mlsource/MLCompiler/CodeTree/CODETREE_SIMPLIFIER.sml index 2ea3c308..da5be956 100644 --- a/mlsource/MLCompiler/CodeTree/CODETREE_SIMPLIFIER.sml +++ b/mlsource/MLCompiler/CodeTree/CODETREE_SIMPLIFIER.sml @@ -1,1774 +1,1774 @@ (* Copyright (c) 2013, 2016-17, 2020 David C.J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) (* This is a cut-down version of the optimiser which simplifies the code but does not apply any heuristics. It follows chained bindings, in particular through tuples, folds constants expressions involving built-in functions, expands inline functions that have previously been marked as inlineable. It does not detect small functions that can be inlined nor does it code-generate functions without free variables. *) functor CODETREE_SIMPLIFIER( structure BASECODETREE: BaseCodeTreeSig structure CODETREE_FUNCTIONS: CodetreeFunctionsSig structure REMOVE_REDUNDANT: sig type codetree type loadForm type codeUse val cleanProc : (codetree * codeUse list * (int -> loadForm) * int) -> codetree structure Sharing: sig type codetree = codetree and loadForm = loadForm and codeUse = codeUse end end - structure DEBUG: DEBUGSIG + structure DEBUG: DEBUG sharing BASECODETREE.Sharing = CODETREE_FUNCTIONS.Sharing = REMOVE_REDUNDANT.Sharing ) : sig type codetree and codeBinding and envSpecial val simplifier: { code: codetree, numLocals: int, maxInlineSize: int } -> (codetree * codeBinding list * envSpecial) * int * bool val specialToGeneral: codetree * codeBinding list * envSpecial -> codetree structure Sharing: sig type codetree = codetree and codeBinding = codeBinding and envSpecial = envSpecial end end = struct open BASECODETREE open Address open CODETREE_FUNCTIONS open BuiltIns exception InternalError = Misc.InternalError exception RaisedException (* The bindings are held internally as a reversed list. This is really only a check that the reversed and forward lists aren't confused. *) datatype revlist = RevList of codeBinding list type simpContext = { lookupAddr: loadForm -> envGeneral * envSpecial, enterAddr: int * (envGeneral * envSpecial) -> unit, nextAddress: unit -> int, reprocess: bool ref, maxInlineSize: int } fun envGeneralToCodetree(EnvGenLoad ext) = Extract ext | envGeneralToCodetree(EnvGenConst w) = Constnt w fun mkDec (laddr, res) = Declar{value = res, addr = laddr, use=[]} fun mkEnv([], exp) = exp | mkEnv(decs, exp as Extract(LoadLocal loadAddr)) = ( (* A common case is where we have a binding as the last item and then a load of that binding. Reduce this so other optimisations are possible. This is still something of a special case that could/should be generalised. *) case List.last decs of Declar{addr=decAddr, value, ... } => if loadAddr = decAddr then mkEnv(List.take(decs, List.length decs - 1), value) else Newenv(decs, exp) | _ => Newenv(decs, exp) ) | mkEnv(decs, exp) = Newenv(decs, exp) fun isConstnt(Constnt _) = true | isConstnt _ = false (* Wrap up the general, bindings and special value as a codetree node. The special entry is discarded except for Constnt entries which are converted to ConstntWithInline. That allows any inlineable code to be carried forward to later passes. *) fun specialToGeneral(g, RevList(b as _ :: _), s) = mkEnv(List.rev b, specialToGeneral(g, RevList [], s)) | specialToGeneral(Constnt(w, p), RevList [], s) = Constnt(w, setInline s p) | specialToGeneral(g, RevList [], _) = g (* Convert a constant to a fixed value. Used in some constant folding. *) val toFix: machineWord -> FixedInt.int = FixedInt.fromInt o Word.toIntX o toShort local val ffiSizeFloat: unit -> int = RunCall.rtsCallFast1 "PolySizeFloat" and ffiSizeDouble: unit -> int = RunCall.rtsCallFast1 "PolySizeDouble" in (* If we have a constant index value we convert that into a byte offset. We need to know the size of the item on this platform. We have to make this check when we actually compile the code because the interpreted version will generally be run on a platform different from the one the pre-built compiler was compiled on. The ML word length will be the same because we have separate pre-built compilers for 32 and 64-bit. Loads from C memory use signed offsets. Loads from ML memory never have a negative offset and are limited by the maximum size of a cell so can always be unsigned. *) fun getMultiplier (LoadStoreMLWord _) = (Word.toInt RunCall.bytesPerWord, false (* unsigned *)) | getMultiplier (LoadStoreMLByte _) = (1, false) | getMultiplier LoadStoreC8 = (1, true (* signed *) ) | getMultiplier LoadStoreC16 = (2, true (* signed *) ) | getMultiplier LoadStoreC32 = (4, true (* signed *) ) | getMultiplier LoadStoreC64 = (8, true (* signed *) ) | getMultiplier LoadStoreCFloat = (ffiSizeFloat(), true (* signed *) ) | getMultiplier LoadStoreCDouble = (ffiSizeDouble(), true (* signed *) ) | getMultiplier LoadStoreUntaggedUnsigned = (Word.toInt RunCall.bytesPerWord, false (* unsigned *)) end fun simplify(c, s) = mapCodetree (simpGeneral s) c (* Process the codetree to return a codetree node. This is used when we don't want the special case. *) and simpGeneral { lookupAddr, ...} (Extract ext) = let val (gen, spec) = lookupAddr ext in SOME(specialToGeneral(envGeneralToCodetree gen, RevList [], spec)) end | simpGeneral context (Newenv envArgs) = SOME(specialToGeneral(simpNewenv(envArgs, context, RevList []))) | simpGeneral context (Lambda lambda) = SOME(Lambda(#1(simpLambda(lambda, context, NONE, NONE)))) | simpGeneral context (Eval {function, argList, resultType}) = SOME(specialToGeneral(simpFunctionCall(function, argList, resultType, context, RevList[]))) (* BuiltIn0 functions can't be processed specially. *) | simpGeneral context (Unary{oper, arg1}) = SOME(specialToGeneral(simpUnary(oper, arg1, context, RevList []))) | simpGeneral context (Binary{oper, arg1, arg2}) = SOME(specialToGeneral(simpBinary(oper, arg1, arg2, context, RevList []))) | simpGeneral context (Arbitrary{oper=ArbCompare test, shortCond, arg1, arg2, longCall}) = SOME(specialToGeneral(simpArbitraryCompare(test, shortCond, arg1, arg2, longCall, context, RevList []))) | simpGeneral context (Arbitrary{oper=ArbArith arith, shortCond, arg1, arg2, longCall}) = SOME(specialToGeneral(simpArbitraryArith(arith, shortCond, arg1, arg2, longCall, context, RevList []))) | simpGeneral context (AllocateWordMemory {numWords, flags, initial}) = SOME(specialToGeneral(simpAllocateWordMemory(numWords, flags, initial, context, RevList []))) | simpGeneral context (Cond(condTest, condThen, condElse)) = SOME(specialToGeneral(simpIfThenElse(condTest, condThen, condElse, context, RevList []))) | simpGeneral context (Tuple { fields, isVariant }) = SOME(specialToGeneral(simpTuple(fields, isVariant, context, RevList []))) | simpGeneral context (Indirect{ base, offset, indKind }) = SOME(specialToGeneral(simpFieldSelect(base, offset, indKind, context, RevList []))) | simpGeneral context (SetContainer{container, tuple, filter}) = let val optCont = simplify(container, context) val (cGen, cDecs, cSpec) = simpSpecial(tuple, context, RevList []) in case cSpec of (* If the tuple is a local binding it is simpler to pick it up from the "special" entry. *) EnvSpecTuple(size, recEnv) => let val fields = List.tabulate(size, envGeneralToCodetree o #1 o recEnv) in SOME(simpPostSetContainer(optCont, Tuple{isVariant=false, fields=fields}, cDecs, filter)) end | _ => SOME(simpPostSetContainer(optCont, cGen, cDecs, filter)) end | simpGeneral (context as { enterAddr, nextAddress, reprocess, ...}) (BeginLoop{loop, arguments, ...}) = let val didReprocess = ! reprocess (* To see if we really need the loop first try simply binding the arguments and process it. It's often the case that if one or more arguments is a constant that the looping case will be eliminated. *) val withoutBeginLoop = simplify(mkEnv(List.map (Declar o #1) arguments, loop), context) fun foldLoop f n (Loop l) = f(l, n) | foldLoop f n (Newenv(_, exp)) = foldLoop f n exp | foldLoop f n (Cond(_, t, e)) = foldLoop f (foldLoop f n t) e | foldLoop f n (Handle {handler, ...}) = foldLoop f n handler | foldLoop f n (SetContainer{tuple, ...}) = foldLoop f n tuple | foldLoop _ n _ = n (* Check if the Loop instruction is there. This assumes that these are the only tail-recursive cases. *) val hasLoop = foldLoop (fn _ => true) false in if not (hasLoop withoutBeginLoop) then SOME withoutBeginLoop else let (* Reset "reprocess". It may have been set in the withoutBeginLoop that's not the code we're going to return. *) val () = reprocess := didReprocess (* We need the BeginLoop. Create new addresses for the arguments. *) fun declArg({addr, value, use, ...}, typ) = let val newAddr = nextAddress() in enterAddr(addr, (EnvGenLoad(LoadLocal newAddr), EnvSpecNone)); ({addr = newAddr, value = simplify(value, context), use = use }, typ) end (* Now look to see if the (remaining) loops have any arguments that do not change. Do this after processing because we could be eliminating other loops that may change the arguments. *) val declArgs = map declArg arguments val beginBody = simplify(loop, context) local fun argsMatch((Extract (LoadLocal argNo), _), ({addr, ...}, _)) = argNo = addr | argsMatch _ = false fun checkLoopArgs(loopArgs, checks) = let fun map3(loopA :: loopArgs, decA :: decArgs, checkA :: checkArgs) = (argsMatch(loopA, decA) andalso checkA) :: map3(loopArgs, decArgs, checkArgs) | map3 _ = [] in map3(loopArgs, declArgs, checks) end in val checkList = foldLoop checkLoopArgs (map (fn _ => true) arguments) beginBody end in if List.exists (fn l => l) checkList then let (* Turn the original arguments into bindings. *) local fun argLists(true, (arg, _), (tArgs, fArgs)) = (Declar arg :: tArgs, fArgs) | argLists(false, arg, (tArgs, fArgs)) = (tArgs, arg :: fArgs) in val (unchangedArgs, filteredDeclArgs) = ListPair.foldrEq argLists ([], []) (checkList, declArgs) end fun changeLoops (Loop loopArgs) = let val newArgs = ListPair.foldrEq(fn (false, arg, l) => arg :: l | (true, _, l) => l) [] (checkList, loopArgs) in Loop newArgs end | changeLoops(Newenv(decs, exp)) = Newenv(decs, changeLoops exp) | changeLoops(Cond(i, t, e)) = Cond(i, changeLoops t, changeLoops e) | changeLoops(Handle{handler, exp, exPacketAddr}) = Handle{handler=changeLoops handler, exp=exp, exPacketAddr=exPacketAddr} | changeLoops(SetContainer{tuple, container, filter}) = SetContainer{tuple=changeLoops tuple, container=container, filter=filter} | changeLoops code = code val beginBody = simplify(changeLoops loop, context) (* Reprocess because we've lost any special part from the arguments that haven't changed. *) val () = reprocess := true in SOME(mkEnv(unchangedArgs, BeginLoop {loop=beginBody, arguments=filteredDeclArgs})) end else SOME(BeginLoop {loop=beginBody, arguments=declArgs}) end end | simpGeneral context (TagTest{test, tag, maxTag}) = ( case simplify(test, context) of Constnt(testResult, _) => if isShort testResult andalso toShort testResult = tag then SOME CodeTrue else SOME CodeFalse | sTest => SOME(TagTest{test=sTest, tag=tag, maxTag=maxTag}) ) | simpGeneral context (LoadOperation{kind, address}) = let (* Try to move constants out of the index. *) val (genAddress, RevList decAddress) = simpAddress(address, getMultiplier kind, context) (* If the base address and index are constant and this is an immutable load we can do this at compile time. *) val result = case (genAddress, kind) of ({base=Constnt(baseAddr, _), index=NONE, offset}, LoadStoreMLWord _) => if isShort baseAddr then LoadOperation{kind=kind, address=genAddress} else let (* Ignore the "isImmutable" flag and look at the immutable status of the memory. Check that this is a word object and that the offset is within range. The code for Vector.sub, for example, raises an exception if the index is out of range but still generates the (unreachable) indexing code. *) val addr = toAddress baseAddr val wordOffset = Word.fromInt offset div RunCall.bytesPerWord in if isMutable addr orelse not(isWords addr) orelse wordOffset >= length addr then LoadOperation{kind=kind, address=genAddress} else Constnt(toMachineWord(loadWord(addr, wordOffset)), []) end | ({base=Constnt(baseAddr, _), index=NONE, offset}, LoadStoreMLByte _) => if isShort baseAddr then LoadOperation{kind=kind, address=genAddress} else let val addr = toAddress baseAddr val wordOffset = Word.fromInt offset div RunCall.bytesPerWord in if isMutable addr orelse not(isBytes addr) orelse wordOffset >= length addr then LoadOperation{kind=kind, address=genAddress} else Constnt(toMachineWord(loadByte(addr, Word.fromInt offset)), []) end | ({base=Constnt(baseAddr, _), index=NONE, offset}, LoadStoreUntaggedUnsigned) => if isShort baseAddr then LoadOperation{kind=kind, address=genAddress} else let val addr = toAddress baseAddr (* We don't currently have loadWordUntagged in Address but it's only ever used to load the string length word so we can use that. *) in if isMutable addr orelse not(isBytes addr) orelse offset <> 0 then LoadOperation{kind=kind, address=genAddress} else Constnt(toMachineWord(String.size(RunCall.unsafeCast addr)), []) end | _ => LoadOperation{kind=kind, address=genAddress} in SOME(mkEnv(List.rev decAddress, result)) end | simpGeneral context (StoreOperation{kind, address, value}) = let val (genAddress, decAddress) = simpAddress(address, getMultiplier kind, context) val (genValue, RevList decValue, _) = simpSpecial(value, context, decAddress) in SOME(mkEnv(List.rev decValue, StoreOperation{kind=kind, address=genAddress, value=genValue})) end | simpGeneral (context as {reprocess, ...}) (BlockOperation{kind, sourceLeft, destRight, length}) = let val multiplier = case kind of BlockOpMove{isByteMove=false} => Word.toInt RunCall.bytesPerWord | BlockOpMove{isByteMove=true} => 1 | BlockOpEqualByte => 1 | BlockOpCompareByte => 1 val (genSrcAddress, RevList decSrcAddress) = simpAddress(sourceLeft, (multiplier, false), context) val (genDstAddress, RevList decDstAddress) = simpAddress(destRight, (multiplier, false), context) val (genLength, RevList decLength, _) = simpSpecial(length, context, RevList []) (* If we have a short length move we're better doing it as a sequence of loads and stores. This is particularly useful with string concatenation. Small here means three or less. Four and eight byte moves are handled as single instructions in the code-generator provided the alignment is correct. *) val shortLength = case genLength of Constnt(lenConst, _) => if isShort lenConst then let val l = toShort lenConst in if l <= 0w3 then SOME l else NONE end else NONE | _ => NONE val combinedDecs = List.rev decSrcAddress @ List.rev decDstAddress @ List.rev decLength val operation = case (shortLength, kind) of (SOME length, BlockOpMove{isByteMove}) => let val _ = reprocess := true (* Frequently the source will be a constant. *) val {base=baseSrc, index=indexSrc, offset=offsetSrc} = genSrcAddress and {base=baseDst, index=indexDst, offset=offsetDst} = genDstAddress (* We don't know if the source is immutable but the destination definitely isn't *) val moveKind = if isByteMove then LoadStoreMLByte{isImmutable=false} else LoadStoreMLWord{isImmutable=false} fun makeMoves offset = if offset = Word.toInt length then [] else NullBinding( StoreOperation{kind=moveKind, address={base=baseDst, index=indexDst, offset=offsetDst+offset*multiplier}, value=LoadOperation{kind=moveKind, address={base=baseSrc, index=indexSrc, offset=offsetSrc+offset*multiplier}}}) :: makeMoves(offset+1) in mkEnv(combinedDecs @ makeMoves 0, CodeZero (* unit result *)) end | (SOME length, BlockOpEqualByte) => (* Comparing with the null string and up to 3 characters. *) let val {base=baseSrc, index=indexSrc, offset=offsetSrc} = genSrcAddress and {base=baseDst, index=indexDst, offset=offsetDst} = genDstAddress val moveKind = LoadStoreMLByte{isImmutable=false} (* Build andalso tree to check each byte. For the null string this simply returns "true". *) fun makeComparison offset = if offset = Word.toInt length then CodeTrue else Cond( Binary{oper=WordComparison{test=TestEqual, isSigned=false}, arg1=LoadOperation{kind=moveKind, address={base=baseSrc, index=indexSrc, offset=offsetSrc+offset*multiplier}}, arg2=LoadOperation{kind=moveKind, address={base=baseDst, index=indexDst, offset=offsetDst+offset*multiplier}}}, makeComparison(offset+1), CodeFalse) in mkEnv(combinedDecs, makeComparison 0) end | _ => mkEnv(combinedDecs, BlockOperation{kind=kind, sourceLeft=genSrcAddress, destRight=genDstAddress, length=genLength}) in SOME operation end | simpGeneral (context as {enterAddr, nextAddress, ...}) (Handle{exp, handler, exPacketAddr}) = let (* We need to make a new binding for the exception packet. *) val expBody = simplify(exp, context) val newAddr = nextAddress() val () = enterAddr(exPacketAddr, (EnvGenLoad(LoadLocal newAddr), EnvSpecNone)) val handleBody = simplify(handler, context) in SOME(Handle{exp=expBody, handler=handleBody, exPacketAddr=newAddr}) end | simpGeneral _ _ = NONE (* Where we have an Indirect or Eval we want the argument as either a tuple or an inline function respectively if that's possible. Getting that also involves various other cases as well. Because a binding may later be used in such a context we treat any binding in that way as well. *) and simpSpecial (Extract ext, { lookupAddr, ...}, tailDecs) = let val (gen, spec) = lookupAddr ext in (envGeneralToCodetree gen, tailDecs, spec) end | simpSpecial (Newenv envArgs, context, tailDecs) = simpNewenv(envArgs, context, tailDecs) | simpSpecial (Lambda lambda, context, tailDecs) = let val (gen, spec) = simpLambda(lambda, context, NONE, NONE) in (Lambda gen, tailDecs, spec) end | simpSpecial (Eval {function, argList, resultType}, context, tailDecs) = simpFunctionCall(function, argList, resultType, context, tailDecs) | simpSpecial (Unary{oper, arg1}, context, tailDecs) = simpUnary(oper, arg1, context, tailDecs) | simpSpecial (Binary{oper, arg1, arg2}, context, tailDecs) = simpBinary(oper, arg1, arg2, context, tailDecs) | simpSpecial (Arbitrary{oper=ArbCompare test, shortCond, arg1, arg2, longCall}, context, tailDecs) = simpArbitraryCompare(test, shortCond, arg1, arg2, longCall, context, tailDecs) | simpSpecial (Arbitrary{oper=ArbArith arith, shortCond, arg1, arg2, longCall}, context, tailDecs) = simpArbitraryArith(arith, shortCond, arg1, arg2, longCall, context, tailDecs) | simpSpecial (AllocateWordMemory{numWords, flags, initial}, context, tailDecs) = simpAllocateWordMemory(numWords, flags, initial, context, tailDecs) | simpSpecial (Cond(condTest, condThen, condElse), context, tailDecs) = simpIfThenElse(condTest, condThen, condElse, context, tailDecs) | simpSpecial (Tuple { fields, isVariant }, context, tailDecs) = simpTuple(fields, isVariant, context, tailDecs) | simpSpecial (Indirect{ base, offset, indKind }, context, tailDecs) = simpFieldSelect(base, offset, indKind, context, tailDecs) | simpSpecial (c: codetree, s: simpContext, tailDecs): codetree * revlist * envSpecial = let (* Anything else - copy it and then split it into the fields. *) fun split(Newenv(l, e), RevList tailDecs) = (* Pull off bindings. *) split (e, RevList(List.rev l @ tailDecs)) | split(Constnt(m, p), tailDecs) = (Constnt(m, p), tailDecs, findInline p) | split(c, tailDecs) = (c, tailDecs, EnvSpecNone) in split(simplify(c, s), tailDecs) end (* Process a Newenv. We need to add the bindings to the context. *) and simpNewenv((envDecs: codeBinding list, envExp), context as { enterAddr, nextAddress, reprocess, ...}, tailDecs): codetree * revlist * envSpecial = let fun copyDecs ([], decs) = simpSpecial(envExp, context, decs) (* End of the list - process the result expression. *) | copyDecs ((Declar{addr, value, ...} :: vs), decs) = ( case simpSpecial(value, context, decs) of (* If this raises an exception stop here. *) vBinding as (Raise _, _, _) => vBinding | vBinding => let (* Add the declaration to the table. *) val (optV, dec) = makeNewDecl(vBinding, context) val () = enterAddr(addr, optV) in copyDecs(vs, dec) end ) | copyDecs(NullBinding v :: vs, decs) = (* Not a binding - process this and the rest.*) ( case simpSpecial(v, context, decs) of (* If this raises an exception stop here. *) vBinding as (Raise _, _, _) => vBinding | (cGen, RevList cDecs, _) => copyDecs(vs, RevList(NullBinding cGen :: cDecs)) ) | copyDecs(RecDecs mutuals :: vs, RevList decs) = (* Mutually recursive declarations. Any of the declarations may refer to any of the others. They should all be lambdas. The front end generates functions with more than one argument (either curried or tupled) as pairs of mutually recursive functions. The main function body takes its arguments on the stack (or in registers) and the auxiliary inline function, possibly nested, takes the tupled or curried arguments and calls it. If the main function is recursive it will first call the inline function which is why the pair are mutually recursive. As far as possible we want to use the main function since that uses the least memory. Specifically, if the function recurses we want the recursive call to pass all the arguments if it can. *) let (* Reorder the function so the explicitly-inlined ones come first. Their code can then be inserted into the main functions. *) local val (inlines, nonInlines) = List.partition ( fn {lambda = { isInline=DontInline, ...}, ... } => false | _ => true) mutuals in val orderedDecs = inlines @ nonInlines end (* Go down the functions creating new addresses for them and entering them in the table. *) val addresses = map (fn {addr, ... } => let val decAddr = nextAddress() in enterAddr (addr, (EnvGenLoad(LoadLocal decAddr), EnvSpecNone)); decAddr end) orderedDecs fun processFunction({ lambda, addr, ... }, newAddr) = let val (gen, spec) = simpLambda(lambda, context, SOME addr, SOME newAddr) (* Update the entry in the table to include any inlineable function. *) val () = enterAddr (addr, (EnvGenLoad (LoadLocal newAddr), spec)) in {addr=newAddr, lambda=gen, use=[]} end val rlist = ListPair.map processFunction (orderedDecs, addresses) in (* and put these declarations onto the list. *) copyDecs(vs, RevList(List.rev(partitionMutualBindings(RecDecs rlist)) @ decs)) end | copyDecs (Container{addr, size, setter, ...} :: vs, RevList decs) = let (* Enter the new address immediately - it's needed in the setter. *) val decAddr = nextAddress() val () = enterAddr (addr, (EnvGenLoad(LoadLocal decAddr), EnvSpecNone)) val (setGen, RevList setDecs, _) = simpSpecial(setter, context, RevList []) in (* If we have inline expanded a function that sets the container we're better off eliminating the container completely. *) case setGen of SetContainer { tuple, filter, container } => let (* Check the container we're setting is the address we've made for it. *) val _ = (case container of Extract(LoadLocal a) => a = decAddr | _ => false) orelse raise InternalError "copyDecs: Container/SetContainer" val newDecAddr = nextAddress() val () = enterAddr (addr, (EnvGenLoad(LoadLocal newDecAddr), EnvSpecNone)) val tupleAddr = nextAddress() val tupleDec = Declar{addr=tupleAddr, use=[], value=tuple} val tupleLoad = mkLoadLocal tupleAddr val resultTuple = BoolVector.foldri(fn (i, true, l) => mkInd(i, tupleLoad) :: l | (_, false, l) => l) [] filter val _ = List.length resultTuple = size orelse raise InternalError "copyDecs: Container/SetContainer size" val containerDec = Declar{addr=newDecAddr, use=[], value=mkTuple resultTuple} (* TODO: We're replacing a container with what is notionally a tuple on the heap. It should be optimised away as a result of a further pass but we currently have indirections from a container for these. On the native platforms that doesn't matter but on 32-in-64 indirecting from the heap and from the stack are different. *) val _ = reprocess := true in copyDecs(vs, RevList(containerDec :: tupleDec :: setDecs @ decs)) end | _ => let (* The setDecs could refer the container itself if we've optimised this with simpPostSetContainer so we must include them within the setter and not lift them out. *) val dec = Container{addr=decAddr, use=[], size=size, setter=mkEnv(List.rev setDecs, setGen)} in copyDecs(vs, RevList(dec :: decs)) end end in copyDecs(envDecs, tailDecs) end (* Prepares a binding for entry into a look-up table. Returns the entry to put into the table together with any bindings that must be made. If the general part of the optVal is a constant we can just put the constant in the table. If it is a load (Extract) it is just renaming an existing entry so we can return it. Otherwise we have to make a new binding and return a load (Extract) entry for it. *) and makeNewDecl((Constnt w, RevList decs, spec), _) = ((EnvGenConst w, spec), RevList decs) (* No need to create a binding for a constant. *) | makeNewDecl((Extract ext, RevList decs, spec), _) = ((EnvGenLoad ext, spec), RevList decs) (* Binding is simply giving a new name to a variable - can ignore this declaration. *) | makeNewDecl((gen, RevList decs, spec), { nextAddress, ...}) = let (* Create a binding for this value. *) val newAddr = nextAddress() in ((EnvGenLoad(LoadLocal newAddr), spec), RevList(mkDec(newAddr, gen) :: decs)) end and simpLambda({body, isInline, name, argTypes, resultType, closure, localCount, ...}, { lookupAddr, reprocess, maxInlineSize, ... }, myOldAddrOpt, myNewAddrOpt) = let (* A new table for the new function. *) val oldAddrTab = Array.array (localCount, NONE) val optClosureList = makeClosure() val isNowRecursive = ref false local fun localOldAddr (LoadLocal addr) = valOf(Array.sub(oldAddrTab, addr)) | localOldAddr (ext as LoadArgument _) = (EnvGenLoad ext, EnvSpecNone) | localOldAddr (ext as LoadRecursive) = (EnvGenLoad ext, EnvSpecNone) | localOldAddr (LoadClosure addr) = let val oldEntry = List.nth(closure, addr) (* If the entry in the closure is our own address this is recursive. *) fun isRecursive(EnvGenLoad(LoadLocal a), SOME b) = if a = b then (isNowRecursive := true; true) else false | isRecursive _ = false in if isRecursive(EnvGenLoad oldEntry, myOldAddrOpt) then (EnvGenLoad LoadRecursive, EnvSpecNone) else let val newEntry = lookupAddr oldEntry val makeClosure = addToClosure optClosureList fun convertResult(genEntry, specEntry) = (* If after looking up the entry we get our new address it's recursive. *) if isRecursive(genEntry, myNewAddrOpt) then (EnvGenLoad LoadRecursive, EnvSpecNone) else let val newGeneral = case genEntry of EnvGenLoad ext => EnvGenLoad(makeClosure ext) | EnvGenConst w => EnvGenConst w (* Have to modify the environment here so that if we look up free variables we add them to the closure. *) fun convertEnv env args = convertResult(env args) val newSpecial = case specEntry of EnvSpecTuple(size, env) => EnvSpecTuple(size, convertEnv env) | EnvSpecInlineFunction(spec, env) => EnvSpecInlineFunction(spec, convertEnv env) | EnvSpecUnary _ => EnvSpecNone (* Don't pass this in *) | EnvSpecBinary _ => EnvSpecNone (* Don't pass this in *) | EnvSpecNone => EnvSpecNone in (newGeneral, newSpecial) end in convertResult newEntry end end and setTab (index, v) = Array.update (oldAddrTab, index, SOME v) in val newAddressAllocator = ref 0 fun mkAddr () = ! newAddressAllocator before newAddressAllocator := ! newAddressAllocator + 1 val newCode = simplify (body, { enterAddr = setTab, lookupAddr = localOldAddr, nextAddress=mkAddr, reprocess = reprocess, maxInlineSize = maxInlineSize }) end val closureAfterOpt = extractClosure optClosureList val localCount = ! newAddressAllocator (* If we have mutually recursive "small" functions we may turn them into recursive functions. We have to remove the "small" status from them to prevent them from being expanded inline anywhere else. The optimiser may turn them back into "small" functions if the recursion is actually tail-recursion. *) val isNowInline = case isInline of SmallInline => if ! isNowRecursive then DontInline else SmallInline | InlineAlways => (* Functions marked as inline could become recursive as a result of other inlining. *) if ! isNowRecursive then DontInline else InlineAlways | DontInline => DontInline (* Clean up the function body at this point if it could be inlined. There are examples where failing to do this can blow up. This can be the result of creating both a general and special function inside an inline function. *) val cleanBody = if isNowInline = DontInline then newCode else REMOVE_REDUNDANT.cleanProc(newCode, [UseExport], LoadClosure, localCount) (* The optimiser checks the size of a function and decides whether it can be inlined. However if we have expanded some other inlines inside the body it may now be too big. In some cases we can get exponential blow-up. We check here that the body is still small enough before allowing it to be used inline. The limit is set to 10 times the optimiser's limit because it seems that otherwise significant functions are not inlined. *) val stillInline = case isNowInline of SmallInline => if evaluateInlining(cleanBody, List.length argTypes, maxInlineSize*10) <> TooBig then SmallInline else DontInline | inl => inl val copiedLambda: lambdaForm = { body = cleanBody, isInline = isNowInline, name = name, closure = closureAfterOpt, argTypes = argTypes, resultType = resultType, localCount = localCount, recUse = [] } (* The optimiser checks the size of a function and decides whether it can be inlined. However if we have expanded some other inlines inside the body it may now be too big. In some cases we can get exponential blow-up. We check here that the body is still small enough before allowing it to be used inline. *) val inlineCode = if stillInline <> DontInline then EnvSpecInlineFunction(copiedLambda, fn addr => (EnvGenLoad(List.nth(closureAfterOpt, addr)), EnvSpecNone)) else EnvSpecNone in ( copiedLambda, inlineCode ) end and simpFunctionCall(function, argList, resultType, context as { reprocess, maxInlineSize, ...}, tailDecs) = let (* Function call - This may involve inlining the function. *) (* Get the function to be called and see if it is inline or a lambda expression. *) val (genFunct, decsFunct, specFunct) = simpSpecial(function, context, tailDecs) (* We have to make a special check here that we are not passing in the function we are trying to expand. This could result in an infinitely recursive expansion. It is only going to happen in very special circumstances such as a definition of the Y combinator. If we see that we don't attempt to expand inline. It could be embedded in a tuple or the closure of a function as well as passed directly. *) val isRecursiveArg = case function of Extract extOrig => let fun containsFunction(Extract thisArg, v) = (v orelse thisArg = extOrig, FOLD_DESCEND) | containsFunction(Lambda{closure, ...}, v) = (* Only the closure, not the body *) (foldl (fn (c, w) => foldtree containsFunction w (Extract c)) v closure, FOLD_DONT_DESCEND) | containsFunction(Eval _, v) = (v, FOLD_DONT_DESCEND) (* OK if it's called *) | containsFunction(_, v) = (v, FOLD_DESCEND) in List.exists(fn (c, _) => foldtree containsFunction false c) argList end | _ => false in case (specFunct, genFunct, isRecursiveArg) of (EnvSpecInlineFunction({body=lambdaBody, localCount, argTypes, ...}, functEnv), _, false) => let val _ = List.length argTypes = List.length argList orelse raise InternalError "simpFunctionCall: argument mismatch" val () = reprocess := true (* If we expand inline we have to reprocess *) and { nextAddress, reprocess, ...} = context (* Expand a function inline, either one marked explicitly to be inlined or one detected as "small". *) (* Calling inline proc or a lambda expression which is just called. The function is replaced with a block containing declarations of the parameters. We need a new table here because the addresses we use to index it are the addresses which are local to the function. New addresses are created in the range of the surrounding function. *) val localVec = Array.array(localCount, NONE) local fun processArgs([], bindings) = ([], bindings) | processArgs((arg, _)::args, bindings) = let val (thisArg, newBindings) = makeNewDecl(simpSpecial(arg, context, bindings), context) val (otherArgs, resBindings) = processArgs(args, newBindings) in (thisArg::otherArgs, resBindings) end val (params, bindings) = processArgs(argList, decsFunct) val paramVec = Vector.fromList params in fun getParameter n = Vector.sub(paramVec, n) (* Bindings necessary for the arguments *) val copiedArgs = bindings end local fun localOldAddr(LoadLocal addr) = valOf(Array.sub(localVec, addr)) | localOldAddr(LoadArgument addr) = getParameter addr | localOldAddr(LoadClosure closureEntry) = functEnv closureEntry | localOldAddr LoadRecursive = raise InternalError "localOldAddr: LoadRecursive" fun setTabForInline (index, v) = Array.update (localVec, index, SOME v) val lambdaContext = { lookupAddr=localOldAddr, enterAddr=setTabForInline, nextAddress=nextAddress, reprocess = reprocess, maxInlineSize = maxInlineSize } in val (cGen, cDecs, cSpec) = simpSpecial(lambdaBody,lambdaContext, copiedArgs) end in (cGen, cDecs, cSpec) end | (_, gen as Constnt _, _) => (* Not inlinable - constant function. *) let val copiedArgs = map (fn (arg, argType) => (simplify(arg, context), argType)) argList val evCopiedCode = Eval {function = gen, argList = copiedArgs, resultType=resultType} in (evCopiedCode, decsFunct, EnvSpecNone) end | (_, gen, _) => (* Anything else. *) let val copiedArgs = map (fn (arg, argType) => (simplify(arg, context), argType)) argList val evCopiedCode = Eval {function = gen, argList = copiedArgs, resultType=resultType} in (evCopiedCode, decsFunct, EnvSpecNone) end end (* Special processing for the current builtIn1 operations. *) (* Constant folding for built-ins. These ought to be type-correct i.e. we should have tagged values in some cases and addresses in others. However there may be run-time tests that would ensure type-correctness and we can't be sure that they will always be folded at compile-time. e.g. we may have if isShort c then shortOp c else longOp c If c is a constant then we may try to fold both the shortOp and the longOp and one of these will be type-incorrect although never executed at run-time. *) and simpUnary(oper, arg1, context as { reprocess, ...}, tailDecs) = let val (genArg1, decArg1, specArg1) = simpSpecial(arg1, context, tailDecs) in case (oper, genArg1) of (NotBoolean, Constnt(v, _)) => ( reprocess := true; (if isShort v andalso toShort v = 0w0 then CodeTrue else CodeFalse, decArg1, EnvSpecNone) ) | (NotBoolean, genArg1) => ( (* NotBoolean: This can be the result of using Bool.not but more usually occurs as a result of other code. We don't have TestNotEqual or IsAddress so both of these use NotBoolean with TestEqual and IsTagged. Also we can insert a NotBoolean as a result of a Cond. We try to eliminate not(not a) and to push other NotBooleans down to a point where a boolean is tested. *) case specArg1 of EnvSpecUnary(NotBoolean, originalArg) => ( (* not(not a) - Eliminate. *) reprocess := true; (originalArg, decArg1, EnvSpecNone) ) | _ => (* Otherwise pass this on. It is also extracted in a Cond. *) (Unary{oper=NotBoolean, arg1=genArg1}, decArg1, EnvSpecUnary(NotBoolean, genArg1)) ) | (IsTaggedValue, Constnt(v, _)) => ( reprocess := true; (if isShort v then CodeTrue else CodeFalse, decArg1, EnvSpecNone) ) | (IsTaggedValue, genArg1) => ( (* We use this to test for nil values and if we have constructed a record (or possibly a function) it can't be null. *) case specArg1 of EnvSpecTuple _ => (CodeFalse, decArg1, EnvSpecNone) before reprocess := true | EnvSpecInlineFunction _ => (CodeFalse, decArg1, EnvSpecNone) before reprocess := true | _ => (Unary{oper=oper, arg1=genArg1}, decArg1, EnvSpecNone) ) | (MemoryCellLength, Constnt(v, _)) => ( reprocess := true; (if isShort v then CodeZero else Constnt(toMachineWord(Address.length(toAddress v)), []), decArg1, EnvSpecNone) ) | (MemoryCellFlags, Constnt(v, _)) => ( reprocess := true; (if isShort v then CodeZero else Constnt(toMachineWord(Address.flags(toAddress v)), []), decArg1, EnvSpecNone) ) | (LongWordToTagged, Constnt(v, _)) => ( reprocess := true; (Constnt(toMachineWord(Word.fromLargeWord(RunCall.unsafeCast v)), []), decArg1, EnvSpecNone) ) | (LongWordToTagged, genArg1) => ( (* If we apply LongWordToTagged to an argument we have created with UnsignedToLongWord we can return the original argument. *) case specArg1 of EnvSpecUnary(UnsignedToLongWord, originalArg) => ( reprocess := true; (originalArg, decArg1, EnvSpecNone) ) | _ => (Unary{oper=LongWordToTagged, arg1=genArg1}, decArg1, EnvSpecNone) ) | (SignedToLongWord, Constnt(v, _)) => ( reprocess := true; (Constnt(toMachineWord(Word.toLargeWordX(RunCall.unsafeCast v)), []), decArg1, EnvSpecNone) ) | (UnsignedToLongWord, Constnt(v, _)) => ( reprocess := true; (Constnt(toMachineWord(Word.toLargeWord(RunCall.unsafeCast v)), []), decArg1, EnvSpecNone) ) | (UnsignedToLongWord, genArg1) => (* Add the operation as the special entry. It can then be recognised by LongWordToTagged. *) (Unary{oper=oper, arg1=genArg1}, decArg1, EnvSpecUnary(UnsignedToLongWord, genArg1)) | _ => (Unary{oper=oper, arg1=genArg1}, decArg1, EnvSpecNone) end and simpBinary(oper, arg1, arg2, context as {reprocess, ...}, tailDecs) = let val (genArg1, decArg1, _ (*specArg1*)) = simpSpecial(arg1, context, tailDecs) val (genArg2, decArgs, _ (*specArg2*)) = simpSpecial(arg2, context, decArg1) in case (oper, genArg1, genArg2) of (WordComparison{test, isSigned}, Constnt(v1, _), Constnt(v2, _)) => if not(isShort v1) orelse not(isShort v2) (* E.g. arbitrary precision on unreachable path. *) then (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) else let val () = reprocess := true val testResult = case (test, isSigned) of (* TestEqual can be applied to addresses. *) (TestEqual, _) => toShort v1 = toShort v2 | (TestLess, false) => toShort v1 < toShort v2 | (TestLessEqual, false) => toShort v1 <= toShort v2 | (TestGreater, false) => toShort v1 > toShort v2 | (TestGreaterEqual, false) => toShort v1 >= toShort v2 | (TestLess, true) => toFix v1 < toFix v2 | (TestLessEqual, true) => toFix v1 <= toFix v2 | (TestGreater, true) => toFix v1 > toFix v2 | (TestGreaterEqual, true) => toFix v1 >= toFix v2 | (TestUnordered, _) => raise InternalError "WordComparison: TestUnordered" in (if testResult then CodeTrue else CodeFalse, decArgs, EnvSpecNone) end | (PointerEq, Constnt(v1, _), Constnt(v2, _)) => ( reprocess := true; (if RunCall.pointerEq(v1, v2) then CodeTrue else CodeFalse, decArgs, EnvSpecNone) ) | (FixedPrecisionArith arithOp, Constnt(v1, _), Constnt(v2, _)) => if not(isShort v1) orelse not(isShort v2) then (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) else let val () = reprocess := true val v1S = toFix v1 and v2S = toFix v2 fun asConstnt v = Constnt(toMachineWord v, []) val raiseOverflow = Raise(Constnt(toMachineWord Overflow, [])) val raiseDiv = Raise(Constnt(toMachineWord Div, [])) (* ?? There's usually an explicit test. *) val resultCode = case arithOp of ArithAdd => (asConstnt(v1S+v2S) handle Overflow => raiseOverflow) | ArithSub => (asConstnt(v1S-v2S) handle Overflow => raiseOverflow) | ArithMult => (asConstnt(v1S*v2S) handle Overflow => raiseOverflow) | ArithQuot => (asConstnt(FixedInt.quot(v1S,v2S)) handle Overflow => raiseOverflow | Div => raiseDiv) | ArithRem => (asConstnt(FixedInt.rem(v1S,v2S)) handle Overflow => raiseOverflow | Div => raiseDiv) | ArithDiv => (asConstnt(FixedInt.div(v1S,v2S)) handle Overflow => raiseOverflow | Div => raiseDiv) | ArithMod => (asConstnt(FixedInt.mod(v1S,v2S)) handle Overflow => raiseOverflow | Div => raiseDiv) in (resultCode, decArgs, EnvSpecNone) end (* Addition and subtraction of zero. These can arise as a result of inline expansion of more general functions. *) | (FixedPrecisionArith ArithAdd, arg1, Constnt(v2, _)) => if isShort v2 andalso toShort v2 = 0w0 then (arg1, decArgs, EnvSpecNone) else (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) | (FixedPrecisionArith ArithAdd, Constnt(v1, _), arg2) => if isShort v1 andalso toShort v1 = 0w0 then (arg2, decArgs, EnvSpecNone) else (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) | (FixedPrecisionArith ArithSub, arg1, Constnt(v2, _)) => if isShort v2 andalso toShort v2 = 0w0 then (arg1, decArgs, EnvSpecNone) else (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) | (WordArith arithOp, Constnt(v1, _), Constnt(v2, _)) => if not(isShort v1) orelse not(isShort v2) then (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) else let val () = reprocess := true val v1S = toShort v1 and v2S = toShort v2 fun asConstnt v = Constnt(toMachineWord v, []) val resultCode = case arithOp of ArithAdd => asConstnt(v1S+v2S) | ArithSub => asConstnt(v1S-v2S) | ArithMult => asConstnt(v1S*v2S) | ArithQuot => raise InternalError "WordArith: ArithQuot" | ArithRem => raise InternalError "WordArith: ArithRem" | ArithDiv => asConstnt(v1S div v2S) | ArithMod => asConstnt(v1S mod v2S) in (resultCode, decArgs, EnvSpecNone) end | (WordArith ArithAdd, arg1, Constnt(v2, _)) => if isShort v2 andalso toShort v2 = 0w0 then (arg1, decArgs, EnvSpecNone) else (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) | (WordArith ArithAdd, Constnt(v1, _), arg2) => if isShort v1 andalso toShort v1 = 0w0 then (arg2, decArgs, EnvSpecNone) else (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) | (WordArith ArithSub, arg1, Constnt(v2, _)) => if isShort v2 andalso toShort v2 = 0w0 then (arg1, decArgs, EnvSpecNone) else (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) | (WordLogical logOp, Constnt(v1, _), Constnt(v2, _)) => if not(isShort v1) orelse not(isShort v2) then (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) else let val () = reprocess := true val v1S = toShort v1 and v2S = toShort v2 fun asConstnt v = Constnt(toMachineWord v, []) val resultCode = case logOp of LogicalAnd => asConstnt(Word.andb(v1S,v2S)) | LogicalOr => asConstnt(Word.orb(v1S,v2S)) | LogicalXor => asConstnt(Word.xorb(v1S,v2S)) in (resultCode, decArgs, EnvSpecNone) end | (WordLogical logop, arg1, Constnt(v2, _)) => (* Return the zero if we are anding with zero otherwise the original arg *) if isShort v2 andalso toShort v2 = 0w0 then (case logop of LogicalAnd => CodeZero | _ => arg1, decArgs, EnvSpecNone) else (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) | (WordLogical logop, Constnt(v1, _), arg2) => if isShort v1 andalso toShort v1 = 0w0 then (case logop of LogicalAnd => CodeZero | _ => arg2, decArgs, EnvSpecNone) else (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) (* TODO: Constant folding of shifts. *) | _ => (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) end (* Arbitrary precision operations. This is a sort of mixture of a built-in and a conditional. *) and simpArbitraryCompare(TestEqual, _, _, _, _, _, _) = (* We no longer generate this for equality. General equality for arbitrary precision uses a combination of PointerEq and byte comparison. *) raise InternalError "simpArbitraryCompare: TestEqual" | simpArbitraryCompare(test, shortCond, arg1, arg2, longCall, context as {reprocess, ...}, tailDecs) = let val (genCond, decCond, _ (*specArg1*)) = simpSpecial(shortCond, context, tailDecs) val (genArg1, decArg1, _ (*specArg1*)) = simpSpecial(arg1, context, decCond) val (genArg2, decArgs, _ (*specArg2*)) = simpSpecial(arg2, context, decArg1) val posFlags = Address.F_bytes and negFlags = Word8.orb(Address.F_bytes, Address.F_negative) in (* Fold any constant/constant operations but more importantly, if we have variable/constant operations where the constant is short we can avoid using the full arbitrary precision call by just looking at the sign bit. *) case (genCond, genArg1, genArg2) of (_, Constnt(v1, _), Constnt(v2, _)) => let val a1: LargeInt.int = RunCall.unsafeCast v1 and a2: LargeInt.int = RunCall.unsafeCast v2 val testResult = case test of TestLess => a1 < a2 | TestGreater => a1 > a2 | TestLessEqual => a1 <= a2 | TestGreaterEqual => a1 >= a2 | _ => raise InternalError "simpArbitraryCompare: Unimplemented function" in (if testResult then CodeTrue else CodeFalse, decArgs, EnvSpecNone) end | (Constnt(c1, _), _, _) => (* The condition is "isShort X andalso isShort Y". This will have been reduced to a constant false or true if either (a) either argument is long or (b) both arguments are short.*) if isShort c1 andalso toShort c1 = 0w0 then (* One argument is definitely long - generate the long form. *) (simplify(longCall, context), decArgs, EnvSpecNone) else (* Both arguments are short. That should mean they're constants. *) (Binary{oper=WordComparison{test=test, isSigned=true}, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) before reprocess := true | (_, genArg1, cArg2 as Constnt _) => let (* The constant must be short otherwise the test would be false. *) val isNeg = case test of TestLess => true | TestLessEqual => true | _ => false (* Translate i < c into if isShort i then toShort i < c else isNegative i *) val newCode = Cond(Unary{oper=BuiltIns.IsTaggedValue, arg1=genArg1}, Binary { oper = BuiltIns.WordComparison{test=test, isSigned=true}, arg1 = genArg1, arg2 = cArg2 }, Binary { oper = BuiltIns.WordComparison{test=TestEqual, isSigned=false}, arg1=Unary { oper = MemoryCellFlags, arg1=genArg1 }, arg2=Constnt(toMachineWord(if isNeg then negFlags else posFlags), [])} ) in (newCode, decArgs, EnvSpecNone) end | (_, cArg1 as Constnt _, genArg2) => let (* We're testing c < i so the test is if isShort i then c < toShort i else isPositive i *) val isPos = case test of TestLess => true | TestLessEqual => true | _ => false val newCode = Cond(Unary{oper=BuiltIns.IsTaggedValue, arg1=genArg2}, Binary { oper = BuiltIns.WordComparison{test=test, isSigned=true}, arg1 = cArg1, arg2 = genArg2 }, Binary { oper = BuiltIns.WordComparison{test=TestEqual, isSigned=false}, arg1=Unary { oper = MemoryCellFlags, arg1=genArg2 }, arg2=Constnt(toMachineWord(if isPos then posFlags else negFlags), [])} ) in (newCode, decArgs, EnvSpecNone) end | _ => (Arbitrary{oper=ArbCompare test, shortCond=genCond, arg1=genArg1, arg2=genArg2, longCall=simplify(longCall, context)}, decArgs, EnvSpecNone) end and simpArbitraryArith(arith, shortCond, arg1, arg2, longCall, context, tailDecs) = let (* arg1 and arg2 are the arguments. shortCond is the condition that must be satisfied in order to use the short precision operation i.e. each argument must be short. *) val (genCond, decCond, _ (*specArg1*)) = simpSpecial(shortCond, context, tailDecs) val (genArg1, decArg1, _ (*specArg1*)) = simpSpecial(arg1, context, decCond) val (genArg2, decArgs, _ (*specArg2*)) = simpSpecial(arg2, context, decArg1) in case (genArg1, genArg2, genCond) of (Constnt(v1, _), Constnt(v2, _), _) => let val a1: LargeInt.int = RunCall.unsafeCast v1 and a2: LargeInt.int = RunCall.unsafeCast v2 (*val _ = print ("Fold arbitrary precision: " ^ PolyML.makestring(arith, a1, a2) ^ "\n")*) in case arith of ArithAdd => (Constnt(toMachineWord(a1+a2), []), decArgs, EnvSpecNone) | ArithSub => (Constnt(toMachineWord(a1-a2), []), decArgs, EnvSpecNone) | ArithMult => (Constnt(toMachineWord(a1*a2), []), decArgs, EnvSpecNone) | _ => raise InternalError "simpArbitraryArith: Unimplemented function" end | (_, _, Constnt(c1, _)) => if isShort c1 andalso toShort c1 = 0w0 then (* One argument is definitely long - generate the long form. *) (simplify(longCall, context), decArgs, EnvSpecNone) else (Arbitrary{oper=ArbArith arith, shortCond=genCond, arg1=genArg1, arg2=genArg2, longCall=simplify(longCall, context)}, decArgs, EnvSpecNone) | _ => (Arbitrary{oper=ArbArith arith, shortCond=genCond, arg1=genArg1, arg2=genArg2, longCall=simplify(longCall, context)}, decArgs, EnvSpecNone) end and simpAllocateWordMemory(numWords, flags, initial, context, tailDecs) = let val (genArg1, decArg1, _ (*specArg1*)) = simpSpecial(numWords, context, tailDecs) val (genArg2, decArg2, _ (*specArg2*)) = simpSpecial(flags, context, decArg1) val (genArg3, decArg3, _ (*specArg3*)) = simpSpecial(initial, context, decArg2) in (AllocateWordMemory{numWords=genArg1, flags=genArg2, initial=genArg3}, decArg3, EnvSpecNone) end (* Loads, stores and block operations use address values. The index value is initially an arbitrary code tree but we can recognise common cases of constant index values or where a constant has been added to the index. TODO: If these are C memory moves we can also look at the base address. The base address for C memory operations is a LargeWord.word value i.e. the address is contained in a box. The base addresses for ML memory moves is an ML address i.e. unboxed. *) and simpAddress({base, index=NONE, offset}, _, context) = let val (genBase, decBase, _ (*specBase*)) = simpSpecial(base, context, RevList[]) in ({base=genBase, index=NONE, offset=offset}, decBase) end | simpAddress({base, index=SOME index, offset: int}, (multiplier: int, isSigned), context) = let val (genBase, RevList decBase, _) = simpSpecial(base, context, RevList[]) val (genIndex, RevList decIndex, _ (* specIndex *)) = simpSpecial(index, context, RevList[]) val (newIndex, newOffset) = case genIndex of Constnt(indexOffset, _) => (* Convert small, positive offsets but leave large values as indexes. We could have silly index values here which will never be executed because of a range check but should still compile. *) if isShort indexOffset then let val indexOffsetW = toShort indexOffset in if indexOffsetW < 0w1000 orelse isSigned andalso indexOffsetW > ~ 0w1000 then (NONE, offset + (if isSigned then Word.toIntX else Word.toInt)indexOffsetW * multiplier) else (SOME genIndex, offset) end else (SOME genIndex, offset) | _ => (SOME genIndex, offset) in ({base=genBase, index=newIndex, offset=newOffset}, RevList(decIndex @ decBase)) end (* (* A built-in function. We can call certain built-ins immediately if the arguments are constants. *) and simpBuiltIn(rtsCallNo, argList, context as { reprocess, ...}) = let val copiedArgs = map (fn arg => simpSpecial(arg, context)) argList open RuntimeCalls (* When checking for a constant we need to check that there are no bindings. They could have side-effects. *) fun isAConstant(Constnt _, [], _) = true | isAConstant _ = false in (* If the function is an RTS call that is safe to evaluate immediately and all the arguments are constants evaluate it now. *) if earlyRtsCall rtsCallNo andalso List.all isAConstant copiedArgs then let val () = reprocess := true exception Interrupt = Thread.Thread.Interrupt (* Turn the arguments into a vector. *) val argVector = case makeConstVal(mkTuple(List.map specialToGeneral copiedArgs)) of Constnt(w, _) => w | _ => raise InternalError "makeConstVal: Not constant" (* Call the function. If it raises an exception (e.g. divide by zero) generate code to raise the exception at run-time. We don't do that for Interrupt which we assume only arises by user interaction and not as a result of executing the code so we reraise that exception immediately. *) val ioOp : int -> machineWord = RunCall.run_call1 RuntimeCalls.POLY_SYS_io_operation (* We need callcode_tupled here because we pass the arguments as a tuple but the RTS functions we're calling expect arguments in registers or on the stack. *) val call: (address * machineWord) -> machineWord = RunCall.run_call1 RuntimeCalls.POLY_SYS_callcode_tupled val code = Constnt (call(toAddress(ioOp rtsCallNo), argVector), []) handle exn as Interrupt => raise exn (* Must not handle this *) | exn => Raise (Constnt(toMachineWord exn, [])) in (code, [], EnvSpecNone) end (* We can optimise certain built-ins in combination with others. If we have POLY_SYS_unsigned_to_longword combined with POLY_SYS_longword_to_tagged we can eliminate both. This can occur in cases such as Word.fromLargeWord o Word8.toLargeWord. If we have POLY_SYS_cmem_load_X functions where the address is formed by adding a constant to an address we can move the addend into the load instruction. *) (* TODO: Could we also have POLY_SYS_signed_to_longword here? *) else if rtsCallNo = POLY_SYS_longword_to_tagged andalso (case copiedArgs of [(_, _, EnvSpecBuiltIn(r, _))] => r = POLY_SYS_unsigned_to_longword | _ => false) then let val arg = (* Get the argument of the argument. *) case copiedArgs of [(_, _, EnvSpecBuiltIn(_, [arg]))] => arg | _ => raise Bind in (arg, [], EnvSpecNone) end else if (rtsCallNo = POLY_SYS_cmem_load_8 orelse rtsCallNo = POLY_SYS_cmem_load_16 orelse rtsCallNo = POLY_SYS_cmem_load_32 orelse rtsCallNo = POLY_SYS_cmem_load_64 orelse rtsCallNo = POLY_SYS_cmem_store_8 orelse rtsCallNo = POLY_SYS_cmem_store_16 orelse rtsCallNo = POLY_SYS_cmem_store_32 orelse rtsCallNo = POLY_SYS_cmem_store_64) andalso (* Check if the first argument is an addition. The second should be a constant. If the addend is a constant it will be a large integer i.e. the address of a byte segment. *) let (* Check that we have a valid value to add to a large word. The cmem_load/store values sign extend their arguments so we use toLargeWordX here. *) fun isAcceptableOffset c = if isShort c (* Shouldn't occur. *) then false else let val l: LargeWord.word = RunCall.unsafeCast c in Word.toLargeWordX(Word.fromLargeWord l) = l end in case copiedArgs of (_, _, EnvSpecBuiltIn(r, args)) :: (Constnt _, _, _) :: _ => r = POLY_SYS_plus_longword andalso (case args of (* If they were both constants we'd have folded them. *) [Constnt(c, _), _] => isAcceptableOffset c | [_, Constnt(c, _)] => isAcceptableOffset c | _ => false) | _ => false end then let (* We have a load or store with an added constant. *) val (base, offset) = case copiedArgs of (_, _, EnvSpecBuiltIn(_, [Constnt(offset, _), base])) :: (Constnt(existing, _), _, _) :: _ => (base, Word.fromLargeWord(RunCall.unsafeCast offset) + toShort existing) | (_, _, EnvSpecBuiltIn(_, [base, Constnt(offset, _)])) :: (Constnt(existing, _), _, _) :: _ => (base, Word.fromLargeWord(RunCall.unsafeCast offset) + toShort existing) | _ => raise Bind val newDecs = List.map(fn h => makeNewDecl(h, context)) copiedArgs val genArgs = List.map(fn ((g, _), _) => envGeneralToCodetree g) newDecs val preDecs = List.foldr (op @) [] (List.map #2 newDecs) val gen = BuiltIn(rtsCallNo, base :: Constnt(toMachineWord offset, []) :: List.drop(genArgs, 2)) in (gen, preDecs, EnvSpecNone) end else let (* Create bindings for the arguments. This ensures that any side-effects in the evaluation of the arguments are performed in the correct order even if the application of the built-in itself is applicative. The new arguments are either loads or constants which are applicative. *) val newDecs = List.map(fn h => makeNewDecl(h, context)) copiedArgs val genArgs = List.map(fn ((g, _), _) => envGeneralToCodetree g) newDecs val preDecs = List.foldr (op @) [] (List.map #2 newDecs) val gen = BuiltIn(rtsCallNo, genArgs) val spec = if reorderable gen then EnvSpecBuiltIn(rtsCallNo, genArgs) else EnvSpecNone in (gen, preDecs, spec) end end *) and simpIfThenElse(condTest, condThen, condElse, context, tailDecs) = (* If-then-else. The main simplification is if we have constants in the test or in both the arms. *) let val word0 = toMachineWord 0 val word1 = toMachineWord 1 val False = word0 val True = word1 in case simpSpecial(condTest, context, tailDecs) of (* If the test is a constant we can return the appropriate arm and ignore the other. *) (Constnt(testResult, _), bindings, _) => let val arm = if wordEq (testResult, False) (* false - return else-part *) then condElse (* if false then x else y == y *) (* if true then x else y == x *) else condThen in simpSpecial(arm, context, bindings) end | (testGen, testbindings as RevList testBList, testSpec) => let fun mkNot (Unary{oper=BuiltIns.NotBoolean, arg1}) = arg1 | mkNot arg = Unary{oper=BuiltIns.NotBoolean, arg1=arg} (* If the test involves a variable that was created with a NOT it's better to move it in here. *) val testCond = case testSpec of EnvSpecUnary(BuiltIns.NotBoolean, arg1) => mkNot arg1 | _ => testGen in case (simpSpecial(condThen, context, RevList[]), simpSpecial(condElse, context, RevList[])) of ((thenConst as Constnt(thenVal, _), RevList [], _), (elseConst as Constnt(elseVal, _), RevList [], _)) => (* Both arms return constants. This situation can arise in situations where we have andalso/orelse where the second "argument" has been reduced to a constant. *) if wordEq (thenVal, elseVal) then (* If the test has a side-effect we have to do it otherwise we can remove it. If we're in a nested andalso/orelse that may mean we can simplify the next level out. *) (thenConst (* or elseConst *), if sideEffectFree testCond then testbindings else RevList(NullBinding testCond :: testBList), EnvSpecNone) (* if x then true else false == x *) else if wordEq (thenVal, True) andalso wordEq (elseVal, False) then (testCond, testbindings, EnvSpecNone) (* if x then false else true == not x *) else if wordEq (thenVal, False) andalso wordEq (elseVal, True) then (mkNot testCond, testbindings, EnvSpecNone) else (* can't optimise *) (Cond (testCond, thenConst, elseConst), testbindings, EnvSpecNone) (* Rewrite "if x then raise y else z" into "(if x then raise y else (); z)" The advantage is that any tuples in z are lifted outside the "if". *) | (thenPart as (Raise _, _:revlist, _), (elsePart, RevList elseBindings, elseSpec)) => (* then-part raises an exception *) (elsePart, RevList(elseBindings @ NullBinding(Cond (testCond, specialToGeneral thenPart, CodeZero)) :: testBList), elseSpec) | ((thenPart, RevList thenBindings, thenSpec), elsePart as (Raise _, _, _)) => (* else part raises an exception *) (thenPart, RevList(thenBindings @ NullBinding(Cond (testCond, CodeZero, specialToGeneral elsePart)) :: testBList), thenSpec) | (thenPart, elsePart) => (Cond (testCond, specialToGeneral thenPart, specialToGeneral elsePart), testbindings, EnvSpecNone) end end (* Tuple construction. Tuples are also used for datatypes and structures (i.e. modules) *) and simpTuple(entries, isVariant, context, tailDecs) = (* The main reason for optimising record constructions is that they appear as tuples in ML. We try to ensure that loads from locally created tuples do not involve indirecting from the tuple but can get the value which was put into the tuple directly. If that is successful we may find that the tuple is never used directly so the use-count mechanism will ensure it is never created. *) let val tupleSize = List.length entries (* The record construction is treated as a block of local declarations so that any expressions which might have side-effects are done exactly once. *) (* We thread the bindings through here to avoid having to append the result. *) fun processFields([], bindings) = ([], bindings) | processFields(field::fields, bindings) = let val (thisField, newBindings) = makeNewDecl(simpSpecial(field, context, bindings), context) val (otherFields, resBindings) = processFields(fields, newBindings) in (thisField::otherFields, resBindings) end val (fieldEntries, allBindings) = processFields(entries, tailDecs) (* Make sure we include any inline code in the result. If this tuple is being "exported" we will lose the "special" part. *) fun envResToCodetree(EnvGenLoad(ext), _) = Extract ext | envResToCodetree(EnvGenConst(w, p), s) = Constnt(w, setInline s p) val generalFields = List.map envResToCodetree fieldEntries val genRec = if List.all isConstnt generalFields then makeConstVal(Tuple{ fields = generalFields, isVariant = isVariant }) else Tuple{ fields = generalFields, isVariant = isVariant } (* Get the field from the tuple if possible. If it's a variant, though, we may try to get an invalid field. See Tests/Succeed/Test167. *) fun getField addr = if addr < tupleSize then List.nth(fieldEntries, addr) else if isVariant then (EnvGenConst(toMachineWord 0, []), EnvSpecNone) else raise InternalError "getField - invalid index" val specRec = EnvSpecTuple(tupleSize, getField) in (genRec, allBindings, specRec) end and simpFieldSelect(base, offset, indKind, context, tailDecs) = let val (genSource, decSource, specSource) = simpSpecial(base, context, tailDecs) in (* Try to do the selection now if possible. *) case specSource of EnvSpecTuple(_, recEnv) => let (* The "special" entry we've found is a tuple. That means that we are taking a field from a tuple we made earlier and so we should be able to get the original code we used when we made the tuple. That might mean the tuple is never used and we can optimise away the construction of it completely. *) val (newGen, newSpec) = recEnv offset in (envGeneralToCodetree newGen, decSource, newSpec) end | _ => (* No special case possible. If the tuple is a constant mkInd/mkVarField will do the selection immediately. *) let val genSelect = case indKind of IndTuple => mkInd(offset, genSource) | IndVariant => mkVarField(offset, genSource) | IndContainer => mkIndContainer(offset, genSource) in (genSelect, decSource, EnvSpecNone) end end (* Process a SetContainer. Unlike the other simpXXX functions this is called after the arguments have been processed. We try to push the SetContainer to the leaves of the expression. This is particularly important with tail-recursive functions that return tuples. Without this the function will lose tail-recursion since each recursion will be followed by code to copy the result back to the previous container. *) and simpPostSetContainer(container, Tuple{fields, ...}, RevList tupleDecs, filter) = let (* Apply the filter now. *) fun select(n, hd::tl) = if n >= BoolVector.length filter then [] else if BoolVector.sub(filter, n) then hd :: select(n+1, tl) else select(n+1, tl) | select(_, []) = [] val selected = select(0, fields) (* Frequently we will have produced an indirection from the same base. These will all be bindings so we have to reverse the process. *) fun findOriginal a = List.find(fn Declar{addr, ...} => addr = a | _ => false) tupleDecs fun checkFields(last, Extract(LoadLocal a) :: tl) = ( case findOriginal a of SOME(Declar{value=Indirect{base=Extract ext, indKind=IndContainer, offset, ...}, ...}) => ( case last of NONE => checkFields(SOME(ext, [offset]), tl) | SOME(lastExt, offsets) => (* It has to be the same base and with increasing offsets (no reordering). *) if lastExt = ext andalso offset > hd offsets then checkFields(SOME(ext, offset :: offsets), tl) else NONE ) | _ => NONE ) | checkFields(_, _ :: _) = NONE | checkFields(last, []) = last fun fieldsToFilter fields = let val maxDest = List.foldl Int.max ~1 fields val filterArray = BoolArray.array(maxDest+1, false) val _ = List.app(fn n => BoolArray.update(filterArray, n, true)) fields in BoolArray.vector filterArray end in case checkFields(NONE, selected) of SOME (ext, fields) => (* It may be a container. *) let val filter = fieldsToFilter fields in case ext of LoadLocal localAddr => let (* Is this a container? If it is and we're copying all of it we can replace the inner container with a binding to the outer. We have to be careful because it is possible that we may create and set the inner container, then have some bindings that do some side-effects with the inner container before then copying it to the outer container. For simplicity and to maintain the condition that the container is set in the tails we only merge the containers if it's at the end (after any "filtering"). *) val allSet = BoolVector.foldl (fn (a, t) => a andalso t) true filter fun findContainer [] = NONE | findContainer (Declar{value, ...} :: tl) = if sideEffectFree value then findContainer tl else NONE | findContainer (Container{addr, size, setter, ...} :: tl) = if localAddr = addr andalso size = BoolVector.length filter andalso allSet then SOME (setter, tl) else NONE | findContainer _ = NONE in case findContainer tupleDecs of SOME (setter, decs) => (* Put in a binding for the inner container address so the setter will set the outer container. For this to work all loads from the stack must use native word length. *) mkEnv(List.rev(Declar{addr=localAddr, value=container, use=[]} :: decs), setter) | NONE => mkEnv(List.rev tupleDecs, SetContainer{container=container, tuple = mkTuple selected, filter=BoolVector.tabulate(List.length selected, fn _ => true)}) end | _ => mkEnv(List.rev tupleDecs, SetContainer{container=container, tuple = mkTuple selected, filter=BoolVector.tabulate(List.length selected, fn _ => true)}) end | NONE => mkEnv(List.rev tupleDecs, SetContainer{container=container, tuple = mkTuple selected, filter=BoolVector.tabulate(List.length selected, fn _ => true)}) end | simpPostSetContainer(container, Cond(ifpt, thenpt, elsept), RevList tupleDecs, filter) = mkEnv(List.rev tupleDecs, Cond(ifpt, simpPostSetContainer(container, thenpt, RevList [], filter), simpPostSetContainer(container, elsept, RevList [], filter))) | simpPostSetContainer(container, Newenv(envDecs, envExp), RevList tupleDecs, filter) = simpPostSetContainer(container, envExp, RevList(List.rev envDecs @ tupleDecs), filter) | simpPostSetContainer(container, BeginLoop{loop, arguments}, RevList tupleDecs, filter) = mkEnv(List.rev tupleDecs, BeginLoop{loop = simpPostSetContainer(container, loop, RevList [], filter), arguments=arguments}) | simpPostSetContainer(_, loop as Loop _, RevList tupleDecs, _) = (* If we are inside a BeginLoop we only set the container on leaves that exit the loop. Loop entries will go back to the BeginLoop so we don't add SetContainer nodes. *) mkEnv(List.rev tupleDecs, loop) | simpPostSetContainer(container, Handle{exp, handler, exPacketAddr}, RevList tupleDecs, filter) = mkEnv(List.rev tupleDecs, Handle{ exp = simpPostSetContainer(container, exp, RevList [], filter), handler = simpPostSetContainer(container, handler, RevList [], filter), exPacketAddr = exPacketAddr}) | simpPostSetContainer(container, tupleGen, RevList tupleDecs, filter) = mkEnv(List.rev tupleDecs, mkSetContainer(container, tupleGen, filter)) fun simplifier{code, numLocals, maxInlineSize} = let val localAddressAllocator = ref 0 val addrTab = Array.array(numLocals, NONE) fun lookupAddr (LoadLocal addr) = valOf(Array.sub(addrTab, addr)) | lookupAddr (env as LoadArgument _) = (EnvGenLoad env, EnvSpecNone) | lookupAddr (env as LoadRecursive) = (EnvGenLoad env, EnvSpecNone) | lookupAddr (LoadClosure _) = raise InternalError "top level reached in simplifier" and enterAddr (addr, tab) = Array.update (addrTab, addr, SOME tab) fun mkAddr () = ! localAddressAllocator before localAddressAllocator := ! localAddressAllocator + 1 val reprocess = ref false val (gen, RevList bindings, spec) = simpSpecial(code, {lookupAddr = lookupAddr, enterAddr = enterAddr, nextAddress = mkAddr, reprocess = reprocess, maxInlineSize = maxInlineSize}, RevList[]) in ((gen, List.rev bindings, spec), ! localAddressAllocator, !reprocess) end fun specialToGeneral(g, b as _ :: _, s) = mkEnv(b, specialToGeneral(g, [], s)) | specialToGeneral(Constnt(w, p), [], s) = Constnt(w, setInline s p) | specialToGeneral(g, [], _) = g structure Sharing = struct type codetree = codetree and codeBinding = codeBinding and envSpecial = envSpecial end end; diff --git a/mlsource/MLCompiler/CodeTree/CODETREE_STATIC_LINK_AND_CASES.sml b/mlsource/MLCompiler/CodeTree/CODETREE_STATIC_LINK_AND_CASES.sml index 2d399c4f..fb1d1fba 100644 --- a/mlsource/MLCompiler/CodeTree/CODETREE_STATIC_LINK_AND_CASES.sml +++ b/mlsource/MLCompiler/CodeTree/CODETREE_STATIC_LINK_AND_CASES.sml @@ -1,881 +1,881 @@ (* Copyright (c) 2012-13, 2015-17, 2020 David C.J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) functor CODETREE_STATIC_LINK_AND_CASES( structure BASECODETREE: BaseCodeTreeSig structure CODETREE_FUNCTIONS: CodetreeFunctionsSig structure GCODE: GENCODESIG - structure DEBUG: DEBUGSIG + structure DEBUG: DEBUG structure PRETTY : PRETTYSIG structure BACKENDTREE: BackendIntermediateCodeSig sharing BASECODETREE.Sharing = CODETREE_FUNCTIONS.Sharing = GCODE.Sharing = PRETTY.Sharing = BACKENDTREE.Sharing ) : CodegenTreeSig = struct open BASECODETREE open Address open BACKENDTREE datatype caseType = datatype BACKENDTREE.caseType exception InternalError = Misc.InternalError open BACKENDTREE.CodeTags (* Property tag to indicate which arguments to a function are functions that are only ever called. *) val closureFreeArgsTag: int list Universal.tag = Universal.tag() datatype maybeCase = IsACase of { cases : (backendIC * word) list, test : backendIC, caseType: caseType, default : backendIC } | NotACase of backendIC fun staticLinkAndCases (pt, localAddressCount) = let fun copyCode (pt, nonLocals, recursive, localCount, localAddresses, argClosure) = let (* "closuresForLocals" is a flag indicating that if the declaration is a function a closure must be made for it. *) val closuresForLocals = Array.array(localCount, false) val newLocalAddresses = Array.array (localCount, 0) val argProperties = Array.array(localCount, []) (* Reference to local or non-local bindings. This sets the "closure" property on the binding depending on how the binding will be used. *) fun locaddr (LoadLocal addr, closure) = let val () = if closure then Array.update (closuresForLocals, addr, true) else () val newAddr = Array.sub(newLocalAddresses, addr) in BICLoadLocal newAddr end | locaddr(LoadArgument addr, closure) = ( argClosure(addr, closure); BICLoadArgument addr ) | locaddr(LoadRecursive, closure) = recursive closure | locaddr(LoadClosure addr, closure) = #1 (nonLocals (addr, closure)) (* Argument properties. This returns information of which arguments can have functions passed in without requiring a full heap closure. *) fun argumentProps(LoadLocal addr) = Array.sub(argProperties, addr) | argumentProps(LoadArgument _) = [] | argumentProps LoadRecursive = [] | argumentProps (LoadClosure addr) = #2 (nonLocals (addr, false)) fun makeDecl addr = let val newAddr = ! localAddresses before (localAddresses := !localAddresses+1) val () = Array.update (closuresForLocals, addr, false) val () = Array.update (newLocalAddresses, addr, newAddr) val () = Array.update (argProperties, addr, []) in newAddr end fun insert(Eval { function = Extract LoadRecursive, argList, resultType, ...}) = let (* Recursive. If we pass an argument in the same position we don't necessarily need a closure. It depends on what else happens to it. *) fun mapArgs(n, (Extract (ext as LoadArgument m), t) :: tail) = (BICExtract(locaddr(ext, n <> m)), t) :: mapArgs(n+1, tail) | mapArgs(n, (c, t) :: tail) = (insert c, t) :: mapArgs(n+1, tail) | mapArgs(_, []) = [] val newargs = mapArgs(0, argList) val func = locaddr(LoadRecursive, (* closure = *) false) in (* If we are calling a function which has been declared this does not require it to have a closure. Any other use of the function would. *) BICEval {function = BICExtract func, argList = newargs, resultType=resultType} end | insert(Eval { function = Extract ext, argList, resultType, ...}) = let (* Non-recursive but a binding. *) val cfArgs = argumentProps ext fun isIn n = not(List.exists(fn m => m = n) cfArgs) fun mapArgs(n, (Extract ext, t) :: tail) = (BICExtract(locaddr(ext, isIn n)), t) :: mapArgs(n+1, tail) | mapArgs(n, (Lambda lam, t) :: tail) = (insertLambda(lam, isIn n), t) :: mapArgs(n+1, tail) | mapArgs(n, (c, t) :: tail) = (insert c, t) :: mapArgs(n+1, tail) | mapArgs(_, []) = [] val newargs = mapArgs(0, argList) val func = locaddr(ext, (* closure = *) false) in (* If we are calling a function which has been declared this does not require it to have a closure. Any other use of the function would. *) BICEval {function = BICExtract func, argList = newargs, resultType=resultType} end | insert(Eval { function = Constnt(w, p), argList, resultType, ...}) = let (* Constant function. *) val cfArgs = case List.find (Universal.tagIs closureFreeArgsTag) p of NONE => [] | SOME u => Universal.tagProject closureFreeArgsTag u fun isIn n = not(List.exists(fn m => m = n) cfArgs) fun mapArgs(n, (Extract ext, t) :: tail) = (BICExtract(locaddr(ext, isIn n)), t) :: mapArgs(n+1, tail) | mapArgs(n, (Lambda lam, t) :: tail) = (insertLambda(lam, isIn n), t) :: mapArgs(n+1, tail) | mapArgs(n, (c, t) :: tail) = (insert c, t) :: mapArgs(n+1, tail) | mapArgs(_, []) = [] val newargs = mapArgs(0, argList) in BICEval {function = BICConstnt (w, p), argList = newargs, resultType=resultType} end | insert(Eval { function = Lambda lam, argList, resultType, ...}) = let (* Call of a lambda. Typically this will be a recursive function that can't be inlined. *) val newargs = map(fn (c, t) => (insert c, t)) argList val (copiedLambda, newClosure, makeRecClosure, _) = copyLambda lam val func = copyProcClosure (copiedLambda, newClosure, makeRecClosure) in BICEval {function = func, argList = newargs, resultType=resultType} end | insert(Eval { function, argList, resultType, ...}) = let (* Process the arguments first. *) val newargs = map(fn (c, t) => (insert c, t)) argList val func = insert function in BICEval {function = func, argList = newargs, resultType=resultType} end | insert(Nullary{oper}) = BICNullary{oper=oper} | insert(Unary { oper, arg1 }) = BICUnary { oper = oper, arg1 = insert arg1 } | insert(Binary { oper, arg1, arg2 }) = BICBinary { oper = oper, arg1 = insert arg1, arg2 = insert arg2 } | insert(Arbitrary { oper=ArbCompare test, shortCond, arg1, arg2, longCall}) = let val insArg1 = insert arg1 and insArg2 = insert arg2 and insCall = insert longCall and insShort = insert shortCond (* We have to rewrite this. e.g. if isShort i andalso isShort j then toShort i < toShort j else callComp(i, j) < 0 This isn't done at the higher level because we'd like to recognise cases of comparisons with short constants *) fun fixedComp(arg1, arg2) = BICBinary { oper = BuiltIns.WordComparison{test=test, isSigned=true}, arg1 = arg1, arg2 = arg2 } in BICCond(insShort, fixedComp(insArg1, insArg2), insCall) end | insert(Arbitrary { oper=ArbArith arith, shortCond, arg1, arg2, longCall}) = let val insArg1 = insert arg1 and insArg2 = insert arg2 and insCall = insert longCall and insShort = insert shortCond in BICArbitrary{oper=arith, shortCond=insShort, arg1=insArg1, arg2=insArg2, longCall=insCall} end | insert(AllocateWordMemory {numWords, flags, initial}) = BICAllocateWordMemory { numWords = insert numWords, flags = insert flags, initial = insert initial } | insert(Extract ext) = (* Load the value bound to an identifier. The closure flag is set to true since the only cases where a closure is not needed, eval and load-andStore, are handled separately. *) BICExtract(locaddr(ext, (* closure = *) true)) | insert(Indirect {base, offset, indKind=IndContainer}) = BICLoadContainer {base = insert base, offset = offset} | insert(Indirect {base, offset, ...}) = BICField {base = insert base, offset = offset} | insert(Constnt wp) = BICConstnt wp (* Constants can be returned untouched. *) | insert(BeginLoop{loop=body, arguments=argList, ...}) = (* Start of tail-recursive inline function. *) let (* Make entries in the tables for the arguments. *) val newAddrs = List.map (fn ({addr, ...}, _) => makeDecl addr) argList (* Process the body. *) val insBody = insert body (* Finally the initial argument values. *) local fun copyDec(({value, ...}, t), addr) = ({addr=addr, value=insert value}, t) in val newargs = ListPair.map copyDec (argList, newAddrs) end in (* Add the kill entries on after the loop. *) BICBeginLoop{loop=insBody, arguments=newargs} end | insert(Loop argList) = (* Jump back to start of tail-recursive function. *) BICLoop(List.map(fn (c, t) => (insert c, t)) argList) | insert(Raise x) = BICRaise (insert x) (* See if we can use a case-instruction. Arguably this belongs in the optimiser but it is only really possible when we have removed redundant declarations. *) | insert(Cond(condTest, condThen, condElse)) = reconvertCase(copyCond (condTest, condThen, condElse)) | insert(Newenv(ptElist, ptExp)) = let (* Process the body. Recurses down the list of declarations and expressions processing each, and then reconstructs the list on the way back. *) fun copyDeclarations ([]) = [] | copyDeclarations (Declar({addr=caddr, value = Lambda lam, ...}) :: vs) = let (* Binding a Lambda - process the function first. *) val newAddr = makeDecl caddr val (copiedLambda, newClosure, makeRecClosure, cfArgs) = copyLambda lam val () = Array.update(argProperties, caddr, cfArgs) (* Process all the references to the function. *) val rest = copyDeclarations vs (* We now know if we need a heap closure. *) val dec = copyProcClosure(copiedLambda, newClosure, makeRecClosure orelse Array.sub(closuresForLocals, caddr)) in BICDeclar{addr=newAddr, value=dec} :: rest end | copyDeclarations (Declar({addr=caddr, value = pt, ...}) :: vs) = let (* Non-function binding. *) val newAddr = makeDecl caddr val rest = copyDeclarations vs in BICDeclar{addr=newAddr, value=insert pt} :: rest end | copyDeclarations (RecDecs mutualDecs :: vs) = let (* Mutually recursive declarations. Any of the declarations may refer to any of the others. This causes several problems in working out the use-counts and whether the functions (they should be functions) need closures. A function will need a closure if any reference would require one (i.e. does anything other than call it). The reference may be from one of the other mutually recursive declarations and may be because that function requires a full closure. This means that once we have dealt with any references in the rest of the containing block we have to repeatedly scan the list of declarations removing those which need closures until we are left with those that do not. The use-counts can only be obtained when all the non-local lists have been copied. *) (* First go down the list making a declaration for each entry. This makes sure there is a table entry for all the declarations. *) val _ = List.map (fn {addr, ...} => makeDecl addr) mutualDecs (* Process the rest of the block. Identifies all other references to these declarations. *) val restOfBlock = copyDeclarations vs (* We now want to find out which of the declarations require closures. First we copy all the declarations, except that we don't copy the non-local lists of functions. *) fun copyDec ({addr=caddr, lambda, ...}) = let val (dec, newClosure, makeRecClosure, cfArgs) = copyLambda lambda val () = if makeRecClosure then Array.update (closuresForLocals, caddr, true) else () val () = Array.update(argProperties, caddr, cfArgs) in (caddr, dec, newClosure) end val copiedDecs = map copyDec mutualDecs (* We now have identified all possible references to the functions apart from those of the closures themselves. Any of closures may refer to any other function so we must iterate until all the functions which need full closures have been processed. *) fun processClosures([], outlist, true) = (* Sweep completed. - Must repeat. *) processClosures(outlist, [], false) | processClosures([], outlist, false) = (* We have processed the whole of the list without finding anything which needs a closure. The remainder do not need full closures. *) let fun mkLightClosure ((addr, value, newClosure)) = let val clos = copyProcClosure(value, newClosure, false) val newAddr = Array.sub(newLocalAddresses, addr) in {addr=newAddr, value=clos} end in map mkLightClosure outlist end | processClosures((h as (caddr, value, newClosure))::t, outlist, someFound) = if Array.sub(closuresForLocals, caddr) then let (* Must copy it. *) val clos = copyProcClosure(value, newClosure, true) val newAddr = Array.sub(newLocalAddresses, caddr) in {addr=newAddr, value=clos} :: processClosures(t, outlist, true) end (* Leave it for the moment. *) else processClosures(t, h :: outlist, someFound) val decs = processClosures(copiedDecs, [], false) local fun isLambda{value=BICLambda _, ...} = true | isLambda _ = false in val (lambdas, nonLambdas) = List.partition isLambda decs end fun asMutual{addr, value = BICLambda lambda} = {addr=addr, lambda=lambda} | asMutual _ = raise InternalError "asMutual" in (* Return the mutual declarations and the rest of the block. *) if null lambdas then map BICDeclar nonLambdas @ restOfBlock (* None left *) else BICRecDecs (map asMutual lambdas) :: (map BICDeclar nonLambdas @ restOfBlock) end (* copyDeclarations.isMutualDecs *) | copyDeclarations (NullBinding v :: vs) = let (* Not a declaration - process this and the rest. *) (* Must process later expressions before earlier ones so that the last references to variables are found correctly. DCJM 30/11/99. *) val copiedRest = copyDeclarations vs; val copiedNode = insert v in (* Expand out blocks *) case copiedNode of BICNewenv(decs, exp) => decs @ (BICNullBinding exp :: copiedRest) | _ => BICNullBinding copiedNode :: copiedRest end | copyDeclarations (Container{addr, size, setter, ...} :: vs) = let val newAddr = makeDecl addr val rest = copyDeclarations vs val setCode = insert setter in BICDecContainer{addr=newAddr, size=size} :: BICNullBinding setCode :: rest end val insElist = copyDeclarations(ptElist @ [NullBinding ptExp]) fun mkEnv([], exp) = exp | mkEnv(decs, exp) = BICNewenv(decs, exp) fun decSequenceWithFinalExp decs = let fun splitLast _ [] = raise InternalError "decSequenceWithFinalExp: empty" | splitLast decs [BICNullBinding exp] = (List.rev decs, exp) | splitLast _ [_] = raise InternalError "decSequenceWithFinalExp: last is not a NullDec" | splitLast decs (hd::tl) = splitLast (hd:: decs) tl in mkEnv(splitLast [] decs) end in (* TODO: Tidy this up. *) decSequenceWithFinalExp insElist end (* isNewEnv *) | insert(Tuple { fields, ...}) = BICTuple (map insert fields) | insert(Lambda lam) = (* Using a lambda in a context other than a call or being passed to a function that is known only to call the function. It requires a heap closure. *) insertLambda(lam, true) | insert(Handle { exp, handler, exPacketAddr }) = let (* The order here is important. We want to make sure that the last reference to a variable really is the last. *) val newAddr = makeDecl exPacketAddr val hand = insert handler val exp = insert exp in BICHandle {exp = exp, handler = hand, exPacketAddr=newAddr} end | insert(SetContainer {container, tuple, filter}) = BICSetContainer{container = insert container, tuple = insert tuple, filter = filter} | insert(TagTest{test, tag, maxTag}) = BICTagTest{test=insert test, tag=tag, maxTag=maxTag} | insert(LoadOperation{kind, address}) = BICLoadOperation{kind=kind, address=insertAddress address} | insert(StoreOperation{kind, address, value}) = BICStoreOperation{kind=kind, address=insertAddress address, value=insert value} | insert(BlockOperation{kind, sourceLeft, destRight, length}) = BICBlockOperation{ kind=kind, sourceLeft=insertAddress sourceLeft, destRight=insertAddress destRight, length=insert length} and insertLambda (lam, needsClosure) = let val (copiedLambda, newClosure, _, _) = copyLambda lam in copyProcClosure (copiedLambda, newClosure, needsClosure) end and insertAddress{base, index, offset} = {base=insert base, index=Option.map insert index, offset=offset} and copyCond (condTest, condThen, condElse): maybeCase = let (* Process the then-part. *) val insThen = insert condThen (* Process the else-part. If it's a conditional process it here. *) val insElse = case condElse of Cond(i, t, e) => copyCond(i, t, e) | _ => NotACase(insert condElse) (* Process the condition after the then- and else-parts. *) val insFirst = insert condTest type caseVal = { tag: word, test: codetree, caseType: caseType } option; (* True if both instructions are loads or indirections with the same effect. More complicated cases could be considered but function calls must always be treated as different. Note: the reason we consider Indirect entries here as well as Extract is because we (used to) defer Indirect entries. *) datatype similarity = Different | Similar of bicLoadForm fun similar (BICExtract a, BICExtract b) = if a = b then Similar a else Different | similar (BICField{offset=aOff, base=aBase}, BICField{offset=bOff, base=bBase}) = if aOff <> bOff then Different else similar (aBase, bBase) | similar _ = Different; (* If we have a call to the int equality operation then we may be able to use an indexed case. N.B. This works equally for word values (unsigned) and fixed precision int (unsigned) but is unsafe for arbitrary precision since the lower levels assume that all values are tagged. This could be used for PointerEq which is what arbitrary precision will generate provided that there was an extra check for long values. N.B. the same also happens for e.g. datatype t = A | B | C | D | E of int*int i.e. one non-nullary constructor. *) fun findCase (BICBinary{oper=BuiltIns.WordComparison{test=BuiltIns.TestEqual, ...}, arg1, arg2}) = let in case (arg1, arg2) of (BICConstnt(c1, _), arg2) => if isShort c1 then SOME{tag=toShort c1, test=arg2, caseType = CaseWord} else NONE (* Not a short constant. *) | (arg1, BICConstnt(c2, _)) => if isShort c2 then SOME{tag=toShort c2, test=arg1, caseType = CaseWord} else NONE (* Not a short constant. *) | _ => NONE (* Wrong number of arguments - should raise exception? *) end | findCase(BICTagTest { test, tag, maxTag }) = SOME { tag=tag, test=test, caseType=CaseTag maxTag } | findCase _ = NONE val testCase = findCase insFirst in case testCase of NONE => (* Can't use a case *) NotACase(BICCond (insFirst, insThen, reconvertCase insElse)) | SOME { tag=caseTags, test=caseTest, caseType=caseCaseTest } => (* Can use a case. Can we combine two cases? If we have an expression like "if x = a then .. else if x = b then ..." we can combine them into a single "case". *) case insElse of IsACase { cases=nextCases, test=nextTest, default=nextDefault, caseType=nextCaseType } => ( case (similar(nextTest, caseTest), caseCaseTest = nextCaseType) of (* Note - it is legal (though completely redundant) for the same case to appear more than once in the list. This is not checked for at this stage. *) (Similar _, true) => IsACase { cases = (insThen, caseTags) :: map (fn (c, l) => (c, l)) nextCases, test = nextTest, default = nextDefault, caseType = caseCaseTest } | _ => (* Two case expressions but they test different variables. We can't combine them. *) IsACase { cases = [(insThen, caseTags)], test = caseTest, default = reconvertCase insElse, caseType=caseCaseTest } ) | NotACase elsePart => (* insElse is not a case *) IsACase { cases = [(insThen, caseTags)], test = caseTest, default = elsePart, caseType=caseCaseTest } end (* Check something that's been created as a Case and see whether it is sparse. If it is turn it back into a sequence of conditionals. This was previously done at the bottom level and the choice of when to use an indexed case was made by the architecture-specific code-generator. That's probably unnecessary and complicates the code-generator. *) and reconvertCase(IsACase{cases, test, default, caseType}) = let (* Count the number of cases and compute the maximum and minimum. *) (* If we are testing on integers we could have negative values here. Because we're using "word" here any negative values are treated as large positive values and so we won't use a "case". If this is a case on constructor tags we know the range. There will always be a "default" which may be anywhere in the range but if we construct a jump table that covers all the values we don't need the range checks. *) val useIndexedCase = case caseType of CaseTag _ => (* Exhaustive *) List.length cases > 4 | _ => let val (_, aLabel) = hd cases fun foldCases((_, w), (min, max)) = (Word.min(w, min), Word.max(w, max)) val (min, max) = List.foldl foldCases (aLabel, aLabel) cases val numberOfCases = List.length cases in numberOfCases > 7 andalso Word.fromInt numberOfCases >= (max - min) div 0w3 end in if useIndexedCase then let (* Create a contiguous range of labels. Eliminate any duplicates which are legal but redundant. *) local val labelCount = List.length cases (* Add an extra field before sorting which retains the ordering for equal labels. *) val ordered = ListPair.zipEq (cases, List.tabulate(labelCount, fn n=>n)) fun leq ((_, w1: word), n1: int) ((_, w2), n2) = if w1 = w2 then n1 <= n2 else w1 < w2 val sorted = List.map #1 (Misc.quickSort leq ordered) (* Filter out any duplicates. *) fun filter [] = [] | filter [p] = [p] | filter ((p as (_, lab1)) :: (q as (_, lab2)) :: tl) = if lab1 = lab2 then p :: filter tl else p :: filter (q :: tl) in val cases = filter sorted end val (isExhaustive, min, max) = case caseType of CaseTag max => (true, 0w0, max) | _ => let val (_, aLabel) = hd cases fun foldCases((_, w), (min, max)) = (Word.min(w, min), Word.max(w, max)) val (min, max) = List.foldl foldCases (aLabel, aLabel) cases in (false, min, max) end (* Create labels for each of the cases. Fill in any gaps with entries that will point to the default. We have to be careful if max happens to be the largest value of Word.word. In that case adding one to the range will give us a value less than max. *) fun extendCase(indexVal, cl as ((c, caseValue) :: cps)) = if indexVal + min = caseValue then SOME c :: extendCase(indexVal+0w1, cps) else NONE :: extendCase(indexVal+0w1, cl) | extendCase(indexVal, []) = (* We may not be at the end if this came from a CaseTag *) if indexVal > max-min then [] else NONE :: extendCase(indexVal+0w1, []) val fullCaseRange = extendCase(0w0, cases) val _ = Word.fromInt(List.length fullCaseRange) = max-min+0w1 orelse raise InternalError "Cases" in BICCase{cases=fullCaseRange, test=test, default=default, isExhaustive=isExhaustive, firstIndex=min} end else let fun reconvert [] = default | reconvert ((c, t) :: rest) = let val test = case caseType of CaseWord => BICBinary{ oper=BuiltIns.WordComparison{test=BuiltIns.TestEqual, isSigned=false}, arg1=test, arg2=BICConstnt(toMachineWord t, [])} | CaseTag maxTag => BICTagTest { test=test, tag=t, maxTag=maxTag } in BICCond(test, c, reconvert rest) end in reconvert cases end end | reconvertCase (NotACase t) = t (* Just a simple conditional. *) (* If "makeClosure" is true the function will need a full closure. It may need a full closure even if makeClosure is false if it involves a recursive reference which will need a closure. *) and copyLambda ({body=lambdaBody, argTypes, name=lambdaName, resultType, localCount, closure=lambdaClosure, ...}: lambdaForm) = let val newGrefs: loadForm list ref = ref [] (* non-local references *) val newNorefs = ref 0 (* number of non-local refs *) val makeClosureForRecursion = ref false (* A new table for the new function. *) fun prev (closureAddr, closure) = let val loadEntry = List.nth(lambdaClosure, closureAddr) (* Returns the closure address of the non-local *) fun makeClosureEntry([], _) = (* not found - construct new entry *) let val () = newGrefs := loadEntry :: !newGrefs; val newAddr = !newNorefs + 1; in newNorefs := newAddr; (* increment count *) newAddr-1 end | makeClosureEntry(oldEntry :: t, newAddr) = if oldEntry = loadEntry then newAddr-1 else makeClosureEntry(t, newAddr - 1) (* Set the closure flag if necessary and get the argument props. At this point we discard the "Load" entry returned by nonLocals and "recursive". The closure will be processed later. *) val argProps = case loadEntry of LoadLocal addr => let val () = if closure then Array.update (closuresForLocals, addr, true) else () in Array.sub(argProperties, addr) end | LoadArgument addr => (argClosure(addr, closure); []) | LoadRecursive => (recursive closure; []) | LoadClosure entry => #2 (nonLocals (entry, closure)) in (* Just return the closure entry. *) (BICLoadClosure(makeClosureEntry (!newGrefs, !newNorefs)), argProps) end fun recCall closure = (* Reference to the closure itself. *) ( if closure then makeClosureForRecursion := true else (); BICLoadRecursive ) local datatype tri = TriUnref | TriCall | TriClosure val argClosureArray = Array.array(List.length argTypes, TriUnref) in fun argClosure(n, t) = Array.update(argClosureArray, n, (* If this is true it requires a closure. If it is false it requires a closure if any other reference does. *) if t orelse Array.sub(argClosureArray, n) = TriClosure then TriClosure else TriCall) fun closureFreeArgs() = Array.foldri(fn (n, TriCall, l) => n :: l | (_, _, l) => l) [] argClosureArray end (* process the body *) val newLocalAddresses = ref 0 val (insertedCode, _) = copyCode (lambdaBody, prev, recCall, localCount, newLocalAddresses, argClosure) val globalRefs = !newGrefs val cfArgs = closureFreeArgs() in (BICLambda { body = insertedCode, name = lambdaName, closure = [], argTypes = map #1 argTypes, resultType = resultType, localCount = ! newLocalAddresses, heapClosure = false }, globalRefs, ! makeClosureForRecursion, cfArgs) end (* copyLambda *) (* Copy the closure of a function which has previously been processed by copyLambda. *) and copyProcClosure (BICLambda{ body, name, argTypes, resultType, localCount, ...}, newClosure, heapClosure) = let (* process the non-locals in this function *) (* If a heap closure is needed then any functions referred to from the closure also need heap closures.*) fun makeLoads ext = locaddr(ext, heapClosure) val copyRefs = rev (map makeLoads newClosure) in BICLambda { body = body, name = name, closure = copyRefs, argTypes = argTypes, resultType = resultType, localCount = localCount, heapClosure = heapClosure orelse null copyRefs (* False if closure is empty *) } end | copyProcClosure(pt, _, _) = pt (* may now be a constant *) (* end copyProcClosure *) in case pt of Lambda lam => let val (copiedLambda, newClosure, _, cfArgs) = copyLambda lam val code = copyProcClosure (copiedLambda, newClosure, true) val props = if null cfArgs then [] else [Universal.tagInject closureFreeArgsTag cfArgs] in (code, props) end | c as Newenv(_, exp) => let val code = insert c fun getProps(Extract(LoadLocal addr)) = let val cfArgs = Array.sub(argProperties, addr) in if null cfArgs then [] else [Universal.tagInject closureFreeArgsTag cfArgs] end | getProps(Tuple { fields, ...}) = let val fieldProps = map getProps fields in if List.all null fieldProps then [] else [Universal.tagInject CodeTags.tupleTag fieldProps] end | getProps _ = [] val props = getProps exp in (code, props) end | c as Constnt(_, p) => (insert c, p) | pt => (insert pt, []) end (* copyCode *) val outputAddresses = ref 0 fun topLevel _ = raise InternalError "outer level reached in copyCode" val (insertedCode, argProperties) = copyCode (pt, topLevel, topLevel, localAddressCount, outputAddresses, fn _ => ()) in (insertedCode, argProperties) end (* staticLinkAndCases *) type closureRef = GCODE.closureRef fun codeGenerate(lambda: lambdaForm, debugSwitches, closure) = let val (code, argProperties) = staticLinkAndCases(Lambda lambda, 0) val backendCode = code val () = if DEBUG.getParameter DEBUG.codetreeAfterOptTag debugSwitches then PRETTY.getCompilerOutput debugSwitches (BACKENDTREE.pretty backendCode) else () val bicLambda = case backendCode of BACKENDTREE.BICLambda lam => lam | _ => raise InternalError "Not BICLambda" val () = GCODE.gencodeLambda(bicLambda, debugSwitches, closure) in argProperties end structure Foreign = GCODE.Foreign (* Sharing can be copied from CODETREE. *) structure Sharing = struct open BASECODETREE.Sharing type closureRef = closureRef end end; diff --git a/mlsource/MLCompiler/CodeTree/X86Code/X86CodetreeToICode.ML b/mlsource/MLCompiler/CodeTree/X86Code/X86CodetreeToICode.ML index 4dc830a1..8b6ca56c 100644 --- a/mlsource/MLCompiler/CodeTree/X86Code/X86CodetreeToICode.ML +++ b/mlsource/MLCompiler/CodeTree/X86Code/X86CodetreeToICode.ML @@ -1,4080 +1,4080 @@ (* Copyright David C. J. Matthews 2016-20 This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) functor X86CodetreeToICode( structure BACKENDTREE: BackendIntermediateCodeSig structure ICODE: ICodeSig - structure DEBUG: DEBUGSIG + structure DEBUG: DEBUG structure X86FOREIGN: FOREIGNCALLSIG structure ICODETRANSFORM: X86ICODETRANSFORMSIG structure CODE_ARRAY: CODEARRAYSIG sharing ICODE.Sharing = ICODETRANSFORM.Sharing = CODE_ARRAY.Sharing ): GENCODESIG = struct open BACKENDTREE open Address open ICODE open CODE_ARRAY exception InternalError = Misc.InternalError local val regs = case targetArch of Native32Bit => [eax, ebx] | Native64Bit => [eax, ebx, r8, r9, r10] | ObjectId32Bit => [eax, esi, r8, r9, r10] val fpResult = case targetArch of Native32Bit => FPReg fp0 | _ => XMMReg xmm0 val fpArgRegs = case targetArch of Native32Bit => [] | _ => [xmm0, xmm1, xmm2] in val generalArgRegs = List.map GenReg regs val floatingPtArgRegs = List.map XMMReg fpArgRegs fun resultReg GeneralType = GenReg eax | resultReg DoubleFloatType = fpResult | resultReg SingleFloatType = fpResult end (* tag a short constant *) fun tag c = 2 * c + 1 (* shift a short constant, but don't set tag bit *) fun semitag c = 2 * c (* Reverse a list and append the second. This is used a lot when converting between the reverse and forward list versions. e.g. codeToICode and codeToICodeRev *) fun revApp([], l) = l | revApp(hd :: tl, l) = revApp(tl, hd :: l) datatype blockStruct = BlockSimple of x86ICode | BlockExit of x86ICode | BlockLabel of int | BlockFlow of controlFlow | BlockBegin of { regArgs: (preg * reg) list, stackArgs: stackLocn list } | BlockRaiseAndHandle of x86ICode * int | BlockOptionalHandle of {call: x86ICode, handler: int, label: int } local open RunCall val F_mutable_bytes = Word.fromLargeWord(Word8.toLargeWord(Word8.orb (F_mutable, F_bytes))) fun makeRealConst l = let val r = allocateByteMemory(0wx8 div bytesPerWord, F_mutable_bytes) fun setBytes([], _) = () | setBytes(hd::tl, n) = (storeByte(r, n, hd); setBytes(tl, n+0wx1)) val () = setBytes(l, 0w0) val () = clearMutableBit r in r end in (* These are floating point constants used to change and mask the sign bit. *) val realSignBit: machineWord = makeRealConst [0wx00, 0wx00, 0wx00, 0wx00, 0wx00, 0wx00, 0wx00, 0wx80] and realAbsMask: machineWord = makeRealConst [0wxff, 0wxff, 0wxff, 0wxff, 0wxff, 0wxff, 0wxff, 0wx7f] and floatSignBit: machineWord = makeRealConst [0wx00, 0wx00, 0wx00, 0wx80, 0wx00, 0wx00, 0wx00, 0wx00] and floatAbsMask: machineWord = makeRealConst [0wxff, 0wxff, 0wxff, 0wx7f, 0wx00, 0wx00, 0wx00, 0wx00] end datatype commutative = Commutative | NonCommutative (* Check that a large-word constant looks right and get the value as a large int*) fun largeWordConstant value = if isShort value then raise InternalError "largeWordConstant: invalid" else let val addr = toAddress value in if length addr <> nativeWordSize div wordSize orelse flags addr <> F_bytes then raise InternalError "largeWordConstant: invalid" else (); LargeWord.toLargeInt(RunCall.unsafeCast addr) end fun codeFunctionToX86({body, localCount, name, argTypes, resultType=fnResultType, closure, ...}:bicLambdaForm, debugSwitches, resultClosure) = let (* Pseudo-registers are allocated sequentially and the properties added to the list. *) val pregCounter = ref 0 val pregPropList = ref [] fun newPReg() = let val regNo = !pregCounter before pregCounter := !pregCounter + 1 val () = pregPropList := RegPropGeneral :: !pregPropList in PReg regNo end and newUReg() = let val regNo = !pregCounter before pregCounter := !pregCounter + 1 val () = pregPropList := RegPropUntagged :: !pregPropList in PReg regNo end and newStackLoc size = let val regNo = !pregCounter before pregCounter := !pregCounter + 1 val () = pregPropList := RegPropStack size :: !pregPropList in StackLoc{size=size, rno=regNo} end and newMergeReg() = let val regNo = !pregCounter before pregCounter := !pregCounter + 1 val () = pregPropList := RegPropMultiple :: !pregPropList in PReg regNo end datatype locationValue = NoLocation | PregLocation of preg | ContainerLocation of { container: stackLocn, stackOffset: int } val locToPregArray = Array.array(localCount, NoLocation) val labelCounter = ref 1 (* Start at 1. Zero is used for the root. *) fun newLabel() = !labelCounter before labelCounter := !labelCounter + 1 val ccRefCounter = ref 0 fun newCCRef() = CcRef(!ccRefCounter) before ccRefCounter := !ccRefCounter + 1 fun constantAsArgument value = if isShort value then IntegerConstant(tag(Word.toLargeIntX(toShort value))) else AddressConstant value (* Create the branch condition from the test, isSigned and jumpOn values. (In)equality tests are the same for signed and unsigned values. *) local open BuiltIns in fun testAsBranch(TestEqual, _, true) = JE | testAsBranch(TestEqual, _, false) = JNE (* Signed tests *) | testAsBranch(TestLess, true, true) = JL | testAsBranch(TestLess, true, false) = JGE | testAsBranch(TestLessEqual, true, true) = JLE | testAsBranch(TestLessEqual, true, false) = JG | testAsBranch(TestGreater, true, true) = JG | testAsBranch(TestGreater, true, false) = JLE | testAsBranch(TestGreaterEqual, true, true) = JGE | testAsBranch(TestGreaterEqual, true, false) = JL (* Unsigned tests *) | testAsBranch(TestLess, false, true) = JB | testAsBranch(TestLess, false, false) = JNB | testAsBranch(TestLessEqual, false, true) = JNA | testAsBranch(TestLessEqual, false, false) = JA | testAsBranch(TestGreater, false, true) = JA | testAsBranch(TestGreater, false, false) = JNA | testAsBranch(TestGreaterEqual, false, true) = JNB | testAsBranch(TestGreaterEqual, false, false) = JB | testAsBranch(TestUnordered, _, _) = raise InternalError "TestUnordered" (* Switch the direction of a test if we turn c op x into x op c. *) fun leftRightTest TestEqual = TestEqual | leftRightTest TestLess = TestGreater | leftRightTest TestLessEqual = TestGreaterEqual | leftRightTest TestGreater = TestLess | leftRightTest TestGreaterEqual = TestLessEqual | leftRightTest TestUnordered = TestUnordered end (* Overflow check. This raises Overflow if the overflow bit is set in the cc. This generates a single block for the function unless there is a handler. As well as reducing the size of the code this also means that overflow checks are generally JO instructions to the end of the code. Since the default branch prediction is not to take forward jumps this should improve prefetching on the normal, non-overflow, path. *) fun checkOverflow ({currHandler=NONE, overflowBlock=ref(SOME overFlowLab), ...}) ccRef = (* It's already been set and there's no surrounding handler - use this. *) let val noOverflowLab = newLabel() in [ BlockFlow(Conditional{ ccRef=ccRef, condition=JO, trueJump=overFlowLab, falseJump=noOverflowLab }), BlockLabel noOverflowLab ] end | checkOverflow ({currHandler=NONE, overflowBlock, ...}) ccRef = let (* *) val overFlowLab = newLabel() and noOverflowLab = newLabel() val packetReg = newPReg() val () = overflowBlock := SOME overFlowLab in [ BlockFlow(Conditional{ ccRef=ccRef, condition=JO, trueJump=overFlowLab, falseJump=noOverflowLab }), BlockLabel overFlowLab, BlockSimple(LoadArgument{source=AddressConstant(toMachineWord(Overflow)), dest=packetReg, kind=movePolyWord}), BlockExit(RaiseExceptionPacket{packetReg=packetReg}), BlockLabel noOverflowLab ] end | checkOverflow ({currHandler=SOME h, ...}) ccRef = let val overFlowLab = newLabel() and noOverflowLab = newLabel() val packetReg = newPReg() in [ BlockFlow(Conditional{ ccRef=ccRef, condition=JO, trueJump=overFlowLab, falseJump=noOverflowLab }), BlockLabel overFlowLab, BlockSimple(LoadArgument{source=AddressConstant(toMachineWord(Overflow)), dest=packetReg, kind=movePolyWord}), BlockRaiseAndHandle(RaiseExceptionPacket{packetReg=packetReg}, h), BlockLabel noOverflowLab ] end fun setAndRestoreRounding (rndMode, doWithRounding) = let open IEEEReal val savedRnd = newUReg() and setRnd = newUReg() in case fpMode of FPModeX87 => [BlockSimple(GetX87ControlReg{dest=savedRnd})] @ (* Set the appropriate bits in the control word. *) (case rndMode of TO_NEAREST => (* The bits need to be zero - just mask them. *) [BlockSimple( ArithmeticFunction{oper=AND, resultReg=setRnd, operand1=savedRnd, operand2=IntegerConstant 0xf3ff, ccRef=newCCRef(), opSize=OpSize32})] | TO_NEGINF => let val wrk = newUReg() in (* Mask the bits and set to 01 *) [BlockSimple( ArithmeticFunction{oper=AND, resultReg=wrk, operand1=savedRnd, operand2=IntegerConstant 0xf3ff, ccRef=newCCRef(), opSize=OpSize32}), BlockSimple( ArithmeticFunction{oper=OR, resultReg=setRnd, operand1=savedRnd, operand2=IntegerConstant 0x400, ccRef=newCCRef(), opSize=OpSize32})] end | TO_POSINF => let val wrk = newUReg() in (* Mask the bits and set to 10 *) [BlockSimple( ArithmeticFunction{oper=AND, resultReg=wrk, operand1=savedRnd, operand2=IntegerConstant 0xf3ff, ccRef=newCCRef(), opSize=OpSize32}), BlockSimple( ArithmeticFunction{oper=OR, resultReg=setRnd, operand1=savedRnd, operand2=IntegerConstant 0x800, ccRef=newCCRef(), opSize=OpSize32})] end | TO_ZERO => (* The bits need to be one - just set them. *) [BlockSimple( ArithmeticFunction{oper=OR, resultReg=setRnd, operand1=savedRnd, operand2=IntegerConstant 0xc00, ccRef=newCCRef(), opSize=OpSize32})]) @ [BlockSimple(SetX87ControlReg{source=setRnd})] @ doWithRounding() @ (* Restore the original rounding. *) [BlockSimple(SetX87ControlReg{source=savedRnd})] | FPModeSSE2 => [BlockSimple(GetSSE2ControlReg{dest=savedRnd})] @ (* Set the appropriate bits in the control word. *) (case rndMode of TO_NEAREST => (* The bits need to be zero - just mask them. *) [BlockSimple( ArithmeticFunction{oper=AND, resultReg=setRnd, operand1=savedRnd, operand2=IntegerConstant 0xffff9fff, ccRef=newCCRef(), opSize=OpSize32})] | TO_NEGINF => let val wrk = newUReg() in (* Mask the bits and set to 01 *) [BlockSimple( ArithmeticFunction{oper=AND, resultReg=wrk, operand1=savedRnd, operand2=IntegerConstant 0xffff9fff, ccRef=newCCRef(), opSize=OpSize32}), BlockSimple( ArithmeticFunction{oper=OR, resultReg=setRnd, operand1=savedRnd, operand2=IntegerConstant 0x2000, ccRef=newCCRef(), opSize=OpSize32})] end | TO_POSINF => let val wrk = newUReg() in (* Mask the bits and set to 10 *) [BlockSimple( ArithmeticFunction{oper=AND, resultReg=wrk, operand1=savedRnd, operand2=IntegerConstant 0xffff9fff, ccRef=newCCRef(), opSize=OpSize32}), BlockSimple( ArithmeticFunction{oper=OR, resultReg=setRnd, operand1=savedRnd, operand2=IntegerConstant 0x4000, ccRef=newCCRef(), opSize=OpSize32})] end | TO_ZERO => (* The bits need to be one - just set them. *) [BlockSimple( ArithmeticFunction{oper=OR, resultReg=setRnd, operand1=savedRnd, operand2=IntegerConstant 0x6000, ccRef=newCCRef(), opSize=OpSize32})]) @ [BlockSimple(SetSSE2ControlReg{source=setRnd})] @ doWithRounding() @ [BlockSimple(SetSSE2ControlReg{source=savedRnd})] end (* Put a floating point value into a box or tag it so the value can be held in a general register. *) fun boxOrTagReal(srcReg, destReg, precision) = if precision = BuiltIns.PrecDouble orelse wordSize <> 0w8 then let open BuiltIns val boxFloat = case (fpMode, precision) of (FPModeX87, PrecDouble) => BoxX87Double | (FPModeX87, PrecSingle) => BoxX87Float | (FPModeSSE2, PrecDouble) => BoxSSE2Double | (FPModeSSE2, PrecSingle) => BoxSSE2Float in [BlockSimple(BoxValue{boxKind=boxFloat, source=srcReg, dest=destReg, saveRegs=[]})] end else [BlockSimple(TagFloat{source=srcReg, dest=destReg})] (* Indicate that the base address is actually an object index where appropriate. *) val memIndexOrObject = case targetArch of ObjectId32Bit => ObjectIndex | _ => NoMemIndex (* Generally we have an offset in words and no index register. *) fun wordOffsetAddress(offset, baseReg: preg): argument = MemoryLocation{offset=offset*Word.toInt wordSize, base=baseReg, index=memIndexOrObject, cache=NONE} (* The large-word operations all work on the value within the box pointed at by the register. We generate all large-word operations using this even where the X86 instruction requires a register. This allows the next level to optimise cases of cascaded instructions and avoid creating boxes for intermediate values. *) fun wordAt reg = wordOffsetAddress(0, reg) val returnAddressEntry = newStackLoc 1 datatype argLoc = ArgInReg of { realReg: reg, argReg: preg } | ArgOnStack of { stackOffset: int, stackReg: stackLocn } (* Pseudo-regs for the result, the closure and the args that were passed in real regs. *) val resultTarget = newPReg() val closureRegAddr = newPReg() (* Create a map for the arguments indicating their register or stack location. *) local (* Select the appropriate argument register depending on the argument type. *) fun argTypesToArgEntries([], _, _, _) = ([], [], [], []) | argTypesToArgEntries(DoubleFloatType :: tl, gRegs, fpReg :: fpRegs, n) = let val (argTypes, argCode, argRegs, stackArgs) = argTypesToArgEntries(tl, gRegs, fpRegs, n-1) val pRegArg = newPReg() and uRegArg = newUReg() in (ArgInReg{realReg=fpReg, argReg=pRegArg} :: argTypes, boxOrTagReal(uRegArg, pRegArg, BuiltIns.PrecDouble) @ argCode, (uRegArg, fpReg) :: argRegs, stackArgs) end | argTypesToArgEntries(SingleFloatType :: tl, gRegs, fpReg :: fpRegs, n) = let val (argTypes, argCode, argRegs, stackArgs) = argTypesToArgEntries(tl, gRegs, fpRegs, n-1) val pRegArg = newPReg() and uRegArg = newUReg() in (ArgInReg{realReg=fpReg, argReg=pRegArg} :: argTypes, boxOrTagReal(uRegArg, pRegArg, BuiltIns.PrecSingle) @ argCode, (uRegArg, fpReg) :: argRegs, stackArgs) end | argTypesToArgEntries(_ :: tl, gReg :: gRegs, fpRegs, n) = (* This deals with general arguments but also with extra floating point arguments. They are boxed as usual. *) let val (argTypes, argCode, argRegs, stackArgs) = argTypesToArgEntries(tl, gRegs, fpRegs, n-1) val argReg=newPReg() in (ArgInReg{realReg=gReg, argReg=argReg} :: argTypes, argCode, (argReg, gReg) :: argRegs, stackArgs) end | argTypesToArgEntries(_ :: tl, [], fpRegs, n) = let val (argTypes, argCode, argRegs, stackArgs) = argTypesToArgEntries(tl, [], fpRegs, n-1) val stackLoc = newStackLoc 1 in (ArgOnStack {stackOffset=n, stackReg = stackLoc } :: argTypes, argCode, argRegs, stackLoc :: stackArgs) end val (argEntries, argCode, argRegs, stackArguments) = argTypesToArgEntries(argTypes, generalArgRegs, floatingPtArgRegs, List.length argTypes) val clReg = case closure of [] => [] | _ => [(closureRegAddr, GenReg edx)] in val argumentVector = Vector.fromList argEntries (* Start code for the function. *) val beginInstructions = argCode @ [BlockBegin{regArgs=clReg @ argRegs, stackArgs=stackArguments @ [returnAddressEntry]}] (* The number of arguments on the stack. Needed in return instrs and tail calls. *) val currentStackArgs = List.length stackArguments end (* The return instruction. This can be added on to various tails but there is always one at the end anyway. *) fun returnInstruction({stackPtr, ...}, target, tailCode) = let val (returnCode, resReg) = case fnResultType of GeneralType => ([], target) | DoubleFloatType => let val resReg = newUReg() in ([BlockSimple(LoadArgument{source=wordAt target, dest=resReg, kind=MoveDouble})], resReg) end | SingleFloatType => let val resReg = newUReg() val unpack = if wordSize = 0w8 then BlockSimple(UntagFloat{source=RegisterArgument target, dest=resReg, cache=NONE}) else BlockSimple(LoadArgument{source=wordAt target, dest=resReg, kind=MoveFloat}) in ([unpack], resReg) end in BlockExit(ReturnResultFromFunction{resultReg=resReg, realReg=resultReg fnResultType, numStackArgs=currentStackArgs}) :: returnCode @ (if stackPtr <> 0 then BlockSimple(ResetStackPtr{numWords=stackPtr, preserveCC=false}) :: tailCode else tailCode) end (* This controls what codeAsArgument returns. Different instructions have different requirements. If an option is set to false the value is instead loaded into a new preg. "const32s" means that it will fit into 32-bits. Any constant satisfies that on X86/32 but on the X86/64 we don't allow addresses because we can't be sure whether they will fit or not. *) type allowedArgument = { anyConstant: bool, const32s: bool, memAddr: bool, existingPreg: bool } val allowInMemMove = (* We can move a 32-bit constant into memory but not a long constant. *) { anyConstant=false, const32s=true, memAddr=false, existingPreg=true } and allowInPReg = { anyConstant=false, const32s=false, memAddr=false, existingPreg=true } (* AllowDefer can be used to ensure that any side-effects are done before something else but otherwise we only evaluate afterwards. *) and allowDefer = { anyConstant=true, const32s=true, memAddr=true, existingPreg=true } datatype destination = SpecificPReg of preg | NoResult | Allowed of allowedArgument (* Context type. *) type context = { loopArgs: (preg list * int * int) option, stackPtr: int, currHandler: int option, overflowBlock: int option ref } (* If a preg has been provided, use that, otherwise generate a new one. *) fun asTarget(SpecificPReg preg) = preg | asTarget NoResult = newPReg() | asTarget(Allowed _) = newPReg() fun moveIfNotAllowed(NoResult, code, arg) = (code, arg, false) | moveIfNotAllowed(Allowed{anyConstant=true, ...}, code, arg as AddressConstant _) = (code, arg, false) | moveIfNotAllowed(Allowed{anyConstant=true, ...}, code, arg as IntegerConstant _) = (code, arg, false) | moveIfNotAllowed(dest as Allowed{const32s=true, ...}, code, arg as IntegerConstant value) = (* This is allowed if the value is within 32-bits *) if is32bit value then (code, arg, false) else moveToTarget(dest, code, arg) | moveIfNotAllowed(dest as Allowed{const32s=true, ...}, code, arg as AddressConstant _) = if targetArch = Native32Bit then (code, arg, false) (* We can store the address directly *) else moveToTarget(dest, code, arg) | moveIfNotAllowed(Allowed{existingPreg=true, ...}, code, arg as RegisterArgument(PReg _)) = (code, arg, false) | moveIfNotAllowed(Allowed{memAddr=true, ...}, code, arg as MemoryLocation _) = (code, arg, false) | moveIfNotAllowed(dest, code, arg) = moveToTarget(dest, code, arg) and moveToTarget(dest, code, arg) = let val target = asTarget dest val moveSize = case arg of AddressConstant _ => movePolyWord | MemoryLocation _ => movePolyWord | _ => moveNativeWord in (code @ [BlockSimple(LoadArgument{source=arg, dest=target, kind=moveSize})], RegisterArgument target, false) end (* Create a bool result from a test by returning true or false. *) fun makeBoolResultRev(condition, ccRef, target, testCode) = let val trueLab = newLabel() and falseLab = newLabel() and mergeLab = newLabel() val mergeReg = newMergeReg() in BlockSimple(LoadArgument{dest=target, source=RegisterArgument mergeReg, kind=Move32Bit}) :: BlockLabel mergeLab :: BlockFlow(Unconditional mergeLab) :: BlockSimple(LoadArgument{dest=mergeReg, source=IntegerConstant(tag 0), kind=Move32Bit}) :: BlockLabel falseLab :: BlockFlow(Unconditional mergeLab) :: BlockSimple(LoadArgument{dest=mergeReg, source=IntegerConstant(tag 1), kind=Move32Bit}) :: BlockLabel trueLab :: BlockFlow(Conditional{ ccRef=ccRef, condition=condition, trueJump=trueLab, falseJump=falseLab }) :: testCode end fun moveIfNotAllowedRev(NoResult, code, arg) = (code, arg, false) | moveIfNotAllowedRev(Allowed{anyConstant=true, ...}, code, arg as AddressConstant _) = (code, arg, false) | moveIfNotAllowedRev(Allowed{anyConstant=true, ...}, code, arg as IntegerConstant _) = (code, arg, false) | moveIfNotAllowedRev(dest as Allowed{const32s=true, ...}, code, arg as IntegerConstant value) = (* This is allowed if the value is within 32-bits *) if is32bit value then (code, arg, false) else moveToTargetRev(dest, code, arg) | moveIfNotAllowedRev(dest as Allowed{const32s=true, ...}, code, arg as AddressConstant _) = if targetArch = Native32Bit then (code, arg, false) else moveToTargetRev(dest, code, arg) | moveIfNotAllowedRev(Allowed{existingPreg=true, ...}, code, arg as RegisterArgument(PReg _)) = (code, arg, false) | moveIfNotAllowedRev(Allowed{memAddr=true, ...}, code, arg as MemoryLocation _) = (code, arg, false) | moveIfNotAllowedRev(dest, code, arg) = moveToTargetRev(dest, code, arg) and moveToTargetRev(dest, code, arg) = let val target = asTarget dest val moveSize = case arg of AddressConstant _ => movePolyWord | MemoryLocation _ => movePolyWord | _ => moveNativeWord in (BlockSimple(LoadArgument{source=arg, dest=target, kind=moveSize}) :: code, RegisterArgument target, false) end (* Use a move if there's no offset or index. We could use an add if there's no index. *) and loadAddress{base, offset=0, index=NoMemIndex, dest} = LoadArgument{source=RegisterArgument base, dest=dest, kind=movePolyWord} | loadAddress{base, offset, index, dest} = LoadEffectiveAddress{base=SOME base, offset=offset, dest=dest, index=index, opSize=nativeWordOpSize} and codeToICodeTarget(instr, context: context, isTail, target) = (* This is really for backwards compatibility. *) let val (code, _, _) = codeToICode(instr, context, isTail, SpecificPReg target) in code end and codeToPReg(instr, context) = let (* Many instructions require an argument in a register. If it's already in a register use that rather than creating a new one. *) val (code, result, _) = codeToICode(instr, context, false, Allowed allowInPReg) val preg = case result of RegisterArgument pr => pr | _ => raise InternalError "codeToPReg" in (code, preg) end and codeToPRegRev(instr, context, tailCode) = let (* Many instructions require an argument in a register. If it's already in a register use that rather than creating a new one. *) val (code, result, _) = codeToICodeRev(instr, context, false, Allowed allowInPReg, tailCode) val preg = case result of RegisterArgument pr => pr | _ => raise InternalError "codeToPRegRev" in (code, preg) end and codeToICode(instr, context, isTail, destination) = let val (code, dest, haveExited) = codeToICodeRev(instr, context, isTail, destination, []) in (List.rev code, dest, haveExited) end (* Main function to turn the codetree into ICode. Optimisation is generally left to later passes. This does detect tail recursion. This builds the result up in reverse order. There was an allocation hotspot in loadFields in the BICTuple case which was eliminated by building the list in reverse and then reversing the result. It seems better to build the list in reverse generally but for the moment there are too many special cases to do everything. *) and codeToICodeRev(BICNewenv (bindings, exp), context: context as {stackPtr=initialSp, ...} , isTail, destination, tailCode) = let (* Process a list of bindings. We need to accumulate the space used by any containers and reset the stack pointer at the end if necessary. *) fun doBindings([], context, tailCode) = (tailCode, context) | doBindings(BICDeclar{value=BICExtract(BICLoadLocal l), addr, ...} :: decs, context, tailCode) = let (* Giving a new name to an existing entry. This should have been removed at a higher level but it doesn't always seem to be. In particular we must treat this specially if it's a container. *) val original = Array.sub(locToPregArray, l) val () = Array.update(locToPregArray, addr, original) in doBindings(decs, context, tailCode) end | doBindings(BICDeclar{value, addr, ...} :: decs, context, tailCode) = let val (code, dest) = codeToPRegRev(value, context, tailCode) val () = Array.update(locToPregArray, addr, PregLocation dest) in doBindings(decs, context, code) end | doBindings(BICRecDecs [{lambda, addr, ...}] :: decs, context, tailCode) = (* We shouldn't have single entries in RecDecs but it seems to occur at the moment. *) let val dest = newPReg() val (code, _, _) = codeToICodeRev(BICLambda lambda, context, false, SpecificPReg dest, tailCode) val () = Array.update(locToPregArray, addr, PregLocation dest) in doBindings(decs, context, code) end | doBindings(BICRecDecs recDecs :: decs, context, tailCode) = let val destRegs = map (fn _ => newPReg()) recDecs (* First build the closures as mutable cells containing zeros. Set the entry in the address table to the register containing the address. *) fun makeClosure({lambda={closure, ...}, addr, ...}, dest, c) = let val () = Array.update(locToPregArray, addr, PregLocation dest) val sizeClosure = List.length closure + (if targetArch = ObjectId32Bit then 2 else 1) open Address fun clear n = if n = sizeClosure then [BlockSimple(AllocateMemoryOperation{size=sizeClosure, flags=if targetArch = ObjectId32Bit then Word8.orb(F_mutable, F_closure) else F_mutable, dest=dest, saveRegs=[]})] else (clear (n+1) @ [BlockSimple( StoreArgument{source=IntegerConstant(tag 0), base=dest, offset=n*Word.toInt wordSize, index=memIndexOrObject, kind=movePolyWord, isMutable=false})]) in c @ clear 0 @ [BlockSimple InitialisationComplete] end val allocClosures = ListPair.foldlEq makeClosure [] (recDecs, destRegs) fun setClosure({lambda as {closure, ...}, ...}, dest, l) = let val clResult = makeConstantClosure() val () = codeFunctionToX86(lambda, debugSwitches, clResult) (* Basically the same as tuple except we load the address of the closure we've made. *) fun loadFields([], _) = [] | loadFields(f :: rest, n) = let val (code, source, _) = codeToICode(BICExtract f, context, false, Allowed allowInMemMove) val storeValue = [BlockSimple(StoreArgument{ source=source, base=dest, offset=n*Word.toInt wordSize, index=memIndexOrObject, kind=movePolyWord, isMutable=false })] in code @ storeValue @ loadFields(rest, n+1) end val setCodeAddress = if targetArch = ObjectId32Bit then let (* We can't get the code address until run time. *) val codeReg = newUReg() val closureReg = newPReg() in map BlockSimple [ LoadArgument{ source=AddressConstant(toMachineWord clResult), dest=closureReg, kind=movePolyWord}, LoadArgument{ source=MemoryLocation{offset=0, base=closureReg, index=ObjectIndex, cache=NONE}, dest=codeReg, kind=Move64Bit}, StoreArgument{ source=RegisterArgument codeReg, offset=0, base=dest, index=ObjectIndex, kind=moveNativeWord, isMutable=false} ] end else let val codeAddr = codeAddressFromClosure clResult val (code, source, _) = moveIfNotAllowed(Allowed allowInMemMove, [], AddressConstant codeAddr) in code @ [BlockSimple( StoreArgument{ source=source, base=dest, offset=0, index=NoMemIndex, kind=movePolyWord, isMutable=false })] end val setFields = setCodeAddress @ loadFields(closure, if targetArch = ObjectId32Bit then 2 else 1) in l @ setFields @ [BlockSimple(LockMutable{addr=dest})] end val setClosures = ListPair.foldlEq setClosure [] (recDecs, destRegs) val code = List.rev(allocClosures @ setClosures) in doBindings(decs, context, code @ tailCode) end | doBindings(BICNullBinding exp :: decs, context, tailCode) = let val (code, _, _) = codeToICodeRev(exp, context, false, NoResult, tailCode) (* And discard result. *) in doBindings(decs, context, code) end | doBindings(BICDecContainer{ addr, size } :: decs, {loopArgs, stackPtr, currHandler, overflowBlock}, tailCode) = let val containerReg = newStackLoc size val () = Array.update(locToPregArray, addr, ContainerLocation{container=containerReg, stackOffset=stackPtr+size}) in doBindings(decs, {loopArgs=loopArgs, stackPtr=stackPtr+size, currHandler=currHandler, overflowBlock=overflowBlock}, BlockSimple(ReserveContainer{size=size, container=containerReg}) :: tailCode) end val (codeBindings, resContext as {stackPtr=finalSp, ...}) = doBindings(bindings, context, tailCode) (* If we have had a container we'll need to reset the stack *) in if initialSp <> finalSp then let val _ = finalSp >= initialSp orelse raise InternalError "codeToICode - stack ptr" val bodyReg = newPReg() and resultReg = asTarget destination val (codeExp, result, haveExited) = codeToICodeRev(exp, resContext, isTail, SpecificPReg bodyReg, codeBindings) val afterAdjustSp = if haveExited then codeExp else BlockSimple(LoadArgument{source=result, dest=resultReg, kind=movePolyWord}) :: BlockSimple(ResetStackPtr{numWords=finalSp-initialSp, preserveCC=false}) :: codeExp in (afterAdjustSp, RegisterArgument resultReg, haveExited) end else codeToICodeRev(exp, resContext, isTail, destination, codeBindings) end | codeToICodeRev(BICConstnt(value, _), _, _, destination, tailCode) = moveIfNotAllowedRev(destination, tailCode, constantAsArgument value) | codeToICodeRev(BICExtract(BICLoadLocal l), {stackPtr, ...}, _, destination, tailCode) = ( case Array.sub(locToPregArray, l) of NoLocation => raise InternalError "codeToICodeRev - local unset" | PregLocation preg => moveIfNotAllowedRev(destination, tailCode, RegisterArgument preg) | ContainerLocation{container, stackOffset} => (* This always returns a ContainerAddr whatever the "allowed". *) (tailCode, ContainerAddr{container=container, stackOffset=stackPtr-stackOffset}, false) ) | codeToICodeRev(BICExtract(BICLoadArgument a), {stackPtr, ...}, _, destination, tailCode) = ( case Vector.sub(argumentVector, a) of ArgInReg{argReg, ...} => (* It was originally in a register. It's now in a preg. *) moveIfNotAllowedRev(destination, tailCode, RegisterArgument argReg) | ArgOnStack{stackOffset, stackReg} => (* Pushed before call. *) let val target = asTarget destination in (BlockSimple(LoadArgument{ source=StackLocation{wordOffset=stackOffset+stackPtr, container=stackReg, field=0, cache=NONE}, dest=target, kind=moveNativeWord}) :: tailCode, RegisterArgument target, false) end ) | codeToICodeRev(BICExtract(BICLoadClosure c), _, _, destination, tailCode) = let (* Add the number of words for the code address. This is 1 in native but 2 in 32-in-64. *) val offset = case targetArch of ObjectId32Bit => c+2 | _ => c+1 in if c >= List.length closure then raise InternalError "BICExtract: closure" else (); (* N.B. We need to add one to the closure entry because zero is the code address. *) moveIfNotAllowedRev(destination, tailCode, wordOffsetAddress(offset, closureRegAddr)) end | codeToICodeRev(BICExtract BICLoadRecursive, _, _, destination, tailCode) = (* If the closure is empty we must use the constant. We can't guarantee that the caller will actually load the closure register if it knows the closure is empty. *) moveIfNotAllowedRev(destination, tailCode, case closure of [] => AddressConstant(closureAsAddress resultClosure) | _ => RegisterArgument closureRegAddr) | codeToICodeRev(BICField{base, offset}, context, _, destination, tailCode) = let val (codeBase, baseEntry, _) = codeToICodeRev(base, context, false, Allowed allowInPReg, tailCode) in (* This should not be used with a container. *) case baseEntry of RegisterArgument baseR => moveIfNotAllowedRev(destination, codeBase, wordOffsetAddress(offset, baseR)) | _ => raise InternalError "codeToICodeRev-BICField" end | codeToICodeRev(BICLoadContainer{base, offset}, context, _, destination, tailCode) = let val (codeBase, baseEntry, _) = codeToICodeRev(base, context, false, Allowed allowInPReg, tailCode) val multiplier = Word.toInt(nativeWordSize div wordSize) in (* If this is a local container we extract the field. *) case baseEntry of RegisterArgument baseR => moveIfNotAllowedRev(destination, codeBase, wordOffsetAddress(offset*multiplier, baseR)) | ContainerAddr{container, stackOffset} => let val target = asTarget destination val finalOffset = stackOffset+offset val _ = finalOffset >= 0 orelse raise InternalError "offset" in (BlockSimple(LoadArgument{ source=StackLocation{wordOffset=finalOffset, container=container, field=offset, cache=NONE}, dest=target, kind=moveNativeWord}) :: tailCode, RegisterArgument target, false) end | _ => raise InternalError "codeToICodeRev-BICField" end | codeToICodeRev(BICEval{function, argList, resultType, ...}, context as { currHandler, ...}, isTail, destination, tailCode) = let val target = asTarget destination (* Create pregs for the closure and each argument. *) val clPReg = newPReg() (* If we have a constant closure we can go directly to the entry point. If the closure is a single word we don't need to load the closure register. *) val (functionCode, closureEntry, callKind) = case function of BICConstnt(addr, _) => let val addrAsAddr = toAddress addr (* If this is a closure we're still compiling we can't get the code address. However if this is directly recursive we can use the recursive convention. *) in if wordEq(closureAsAddress resultClosure, addr) then (tailCode, [], Recursive) else if flags addrAsAddr <> Address.F_words andalso flags addrAsAddr <> Address.F_closure then (BlockSimple(LoadArgument{source=AddressConstant addr, dest=clPReg, kind=movePolyWord}) :: tailCode, [(RegisterArgument clPReg, GenReg edx)], FullCall) else if targetArch = ObjectId32Bit then (* We can't actually load the code address here. *) let val addrLength = length addrAsAddr val _ = addrLength >= 0w1 orelse raise InternalError "BICEval address" val _ = flags addrAsAddr = Address.F_closure orelse raise InternalError "BICEval address not a closure" in if addrLength = 0w2 then (tailCode, [], ConstantCode addr) else (BlockSimple(LoadArgument{source=AddressConstant addr, dest=clPReg, kind=movePolyWord}) :: tailCode, [(RegisterArgument clPReg, GenReg edx)], ConstantCode addr) end else (* Native 32 or 64-bits. *) let val addrLength = length addrAsAddr val _ = addrLength >= 0w1 orelse raise InternalError "BICEval address" val codeAddr = loadWord(addrAsAddr, 0w0) val _ = isCode (toAddress codeAddr) orelse raise InternalError "BICEval address not code" in if addrLength = 0w1 then (tailCode, [], ConstantCode codeAddr) else (BlockSimple(LoadArgument{source=AddressConstant addr, dest=clPReg, kind=movePolyWord}) :: tailCode, [(RegisterArgument clPReg, GenReg edx)], ConstantCode codeAddr) end end | BICExtract BICLoadRecursive => ( (* If the closure is empty we don't need to load rdx *) case closure of [] => (tailCode, [], Recursive) | _ => (BlockSimple(LoadArgument {source=RegisterArgument closureRegAddr, dest=clPReg, kind=movePolyWord}) :: tailCode, [(RegisterArgument clPReg, GenReg edx)], Recursive) ) | function => (* General case. *) (#1 (codeToICodeRev(function, context, false, SpecificPReg clPReg, tailCode)), [(RegisterArgument clPReg, GenReg edx)], FullCall) (* Optimise arguments. We have to be careful with tail-recursive functions because they need to save any stack arguments that could be overwritten. This is complicated because we overwrite the stack before loading the register arguments. In some circumstances it could be safe but for the moment leave it. This should be safe in the new code-transform but not the old codeICode. Currently we don't allow memory arguments at all. There's the potential for problems later. Memory arguments could possibly lead to aliasing of the stack if the memory actually refers to a container on the stack. That would mess up the code that ensures that stack arguments are stored in the right order. *) (* We don't allow long constants in stack arguments to a tail-recursive call because we may use a memory move to set them. We also don't allow them in 32-in-64 because we can't push an address constant. *) val allowInStackArg = Allowed {anyConstant=not isTail andalso targetArch <> ObjectId32Bit, const32s=true, memAddr=false, existingPreg=not isTail } and allowInRegArg = Allowed {anyConstant=true, const32s=true, memAddr=false, existingPreg=not isTail } (* Load the first arguments into registers and the rest to the stack. *) fun loadArgs ([], _, _, tailCode) = (tailCode, [], []) | loadArgs ((arg, DoubleFloatType) :: args, gRegs, fpReg :: fpRegs, tailCode) = let (* Floating point register argument. *) val (c, r) = codeToPRegRev(arg, context, tailCode) val r1 = newUReg() val c1 = BlockSimple(LoadArgument{source=wordAt r, dest=r1, kind=MoveDouble}) :: c val (code, regArgs, stackArgs) = loadArgs(args, gRegs, fpRegs, c1) in (code, (RegisterArgument r1, fpReg) :: regArgs, stackArgs) end | loadArgs ((arg, SingleFloatType) :: args, gRegs, fpReg :: fpRegs, tailCode) = let (* Floating point register argument. *) val (c, r) = codeToPRegRev(arg, context, tailCode) val r1 = newUReg() val c1 = if wordSize = 0w8 then BlockSimple(UntagFloat{source=RegisterArgument r, dest=r1, cache=NONE}) :: c else BlockSimple(LoadArgument{source=wordAt r, dest=r1, kind=MoveFloat}) :: c val (code, regArgs, stackArgs) = loadArgs(args, gRegs, fpRegs, c1) in (code, (RegisterArgument r1, fpReg) :: regArgs, stackArgs) end | loadArgs ((arg, _) :: args, gReg::gRegs, fpRegs, tailCode) = let (* General register argument. *) val (c, r, _) = codeToICodeRev(arg, context, false, allowInRegArg, tailCode) val (code, regArgs, stackArgs) = loadArgs(args, gRegs, fpRegs, c) in (code, (r, gReg) :: regArgs, stackArgs) end | loadArgs ((arg, _) :: args, [], fpRegs, tailCode) = let (* Stack argument. *) val (c, r, _) = codeToICodeRev(arg, context, false, allowInStackArg, tailCode) val (code, regArgs, stackArgs) = loadArgs(args, [], fpRegs, c) in (code, regArgs, r :: stackArgs) end val (codeArgs, regArgs, stackArgs) = loadArgs(argList, generalArgRegs, floatingPtArgRegs, functionCode) (* If this is at the end of the function and the result types are the same we can use a tail-recursive call. *) val tailCall = isTail andalso resultType = fnResultType val callCode = if tailCall then let val {stackPtr, ...} = context (* The number of arguments currently on the stack. *) val currentStackArgCount = currentStackArgs val newStackArgCount = List.length stackArgs (* The offset of the first argument or the return address if there are no stack arguments. N.B. We actually have currentStackArgCount+1 items on the stack including the return address. Offsets can be negative. *) val stackOffset = stackPtr val firstArgumentAddr = currentStackArgCount fun makeStackArgs([], _) = [] | makeStackArgs(arg::args, offset) = {src=arg, stack=offset} :: makeStackArgs(args, offset-1) val stackArgs = makeStackArgs(stackArgs, firstArgumentAddr) (* The stack adjustment needed to compensate for any items that have been pushed and the differences in the number of arguments. May be positive or negative. This is also the destination address of the return address so when we enter the new function the return address will be the first item on the stack. *) val stackAdjust = firstArgumentAddr - newStackArgCount (* Add an entry for the return address to the stack arguments. *) val returnEntry = {src=StackLocation{wordOffset=stackPtr, container=returnAddressEntry, field=0, cache=NONE}, stack=stackAdjust} (* Because we're storing into the stack we may be overwriting values we want. If the source of any value is a stack location below the current stack pointer we load it except in the special case where the destination is the same as the source (which is often the case with the return address). *) local fun loadArgs [] = ([], []) | loadArgs (arg :: rest) = let val (loadCode, loadedArgs) = loadArgs rest in case arg of {src as StackLocation{wordOffset, ...}, stack} => if wordOffset = stack+stackOffset (* Same location *) orelse stack+stackOffset < 0 (* Storing above current top of stack *) orelse stackOffset+wordOffset > ~ stackAdjust (* Above the last argument *) then (loadCode, arg :: loadedArgs) else let val preg = newPReg() in (BlockSimple(LoadArgument{source=src, dest=preg, kind=moveNativeWord}) :: loadCode, {src=RegisterArgument preg, stack=stack} :: loadedArgs) end | _ => (loadCode, arg :: loadedArgs) end in val (loadStackArgs, loadedStackArgs) = loadArgs(returnEntry :: stackArgs) end in BlockExit(TailRecursiveCall{regArgs=closureEntry @ regArgs, stackArgs=loadedStackArgs, stackAdjust = stackAdjust, currStackSize=stackOffset, callKind=callKind, workReg=newPReg()}) :: loadStackArgs @ codeArgs end else let val (moveResult, resReg) = case resultType of GeneralType => ([], target) | DoubleFloatType => let val fpRegDest = newUReg() in (boxOrTagReal(fpRegDest, target, BuiltIns.PrecDouble), fpRegDest) end | SingleFloatType => let val fpRegDest = newUReg() in (boxOrTagReal(fpRegDest, target, BuiltIns.PrecSingle), fpRegDest) end val call = FunctionCall{regArgs=closureEntry @ regArgs, stackArgs=stackArgs, dest=resReg, realDest=resultReg resultType, callKind=callKind, saveRegs=[]} val callBlock = case currHandler of NONE => BlockSimple call :: codeArgs | SOME h => BlockOptionalHandle{call=call, handler=h, label=newLabel()} :: codeArgs in moveResult @ callBlock end in (callCode, RegisterArgument target, tailCall (* We've exited if this was a tail jump *)) end | codeToICodeRev(BICNullary{oper=BuiltIns.GetCurrentThreadId}, _, _, destination, tailCode) = (* Get the ID of the current thread. *) let val target = asTarget destination in (BlockSimple(LoadMemReg{offset=memRegThreadSelf, dest=target, kind=movePolyWord}) :: tailCode, RegisterArgument target, false) end | codeToICodeRev(BICNullary{oper=BuiltIns.CheckRTSException}, { currHandler, ...}, _, _, tailCode) = let (* Raise an exception in ML if the last RTS call set the exception packet. *) val haveException = newLabel() and noException = newLabel() val ccRef = newCCRef() val testReg = newPReg() val raiseCode = RaiseExceptionPacket{packetReg=testReg} val code = BlockLabel noException :: (case currHandler of NONE => BlockExit raiseCode | SOME h => BlockRaiseAndHandle(raiseCode, h)) :: BlockLabel haveException :: BlockFlow(Conditional{ ccRef=ccRef, condition=JNE, trueJump=haveException, falseJump=noException }) :: BlockSimple(CompareLiteral{arg1=RegisterArgument testReg, arg2=tag 0, opSize=polyWordOpSize, ccRef=ccRef}) :: BlockSimple(LoadMemReg{offset=memRegExceptionPacket, dest=testReg, kind=movePolyWord}) :: tailCode in (code, (* Unit result *) IntegerConstant(tag 0), false) end | codeToICodeRev(BICUnary instr, context, isTail, destination, tailCode) = codeToICodeUnaryRev(instr, context, isTail, destination, tailCode) | codeToICodeRev(BICBinary instr, context, isTail, destination, tailCode) = codeToICodeBinaryRev(instr, context, isTail, destination, tailCode) | codeToICodeRev(BICArbitrary{oper, shortCond, arg1, arg2, longCall}, context, _, destination, tailCode) = let val startLong = newLabel() and resultLabel = newLabel() val target = asTarget destination val condResult = newMergeReg() (* Overflow check - if there's an overflow jump to the long precision case. *) fun jumpOnOverflow ccRef = let val noOverFlow = newLabel() in [BlockFlow(Conditional{ ccRef=ccRef, condition=JO, trueJump=startLong, falseJump=noOverFlow }), BlockLabel noOverFlow] end val (longCode, _, _) = codeToICode(longCall, context, false, SpecificPReg condResult) (* We could use a tail jump here if this is a tail. *) val (code, dest, haveExited) = ( (* Test the tag bits and skip to the long case if either is clear. *) List.rev(codeConditionRev(shortCond, context, false, startLong, [])) @ (* Try evaluating as fixed precision and jump if we get an overflow. *) codeFixedPrecisionArith(oper, arg1, arg2, context, condResult, jumpOnOverflow) @ (* If we haven't had an overflow jump to the result. *) [BlockFlow(Unconditional resultLabel), (* If we need to use the full long-precision call we come here. *) BlockLabel startLong] @ longCode @ [BlockLabel resultLabel, BlockSimple(LoadArgument{source=RegisterArgument condResult, dest=target, kind=movePolyWord})], RegisterArgument target, false) in (revApp(code, tailCode), dest, haveExited) end | codeToICodeRev(BICAllocateWordMemory instr, context, isTail, destination, tailCode) = let val (code, dest, haveExited) = codeToICodeAllocate(instr, context, isTail, destination) in (revApp(code, tailCode), dest, haveExited) end | codeToICodeRev(BICLambda(lambda as { closure = [], ...}), _, _, destination, tailCode) = (* Empty closure - create a constant closure for any recursive calls. *) let val closure = makeConstantClosure() val () = codeFunctionToX86(lambda, debugSwitches, closure) (* Return the closure itself as the value. *) in moveIfNotAllowedRev(destination, tailCode, AddressConstant(closureAsAddress closure)) end | codeToICodeRev(BICLambda(lambda as { closure, ...}), context, isTail, destination, tailCode) = (* Non-empty closure. Ignore stack closure option at the moment. *) let val closureRef = makeConstantClosure() val () = codeFunctionToX86(lambda, debugSwitches, closureRef) in if targetArch = ObjectId32Bit then let val target = asTarget destination val memAddr = newPReg() fun loadFields([], n, tlCode) = let val codeReg = newUReg() val closureReg = newPReg() in (* The code address occupies the first native word but we need to extract it at run-time. We don't currently have a way to have 64-bit constants. *) BlockSimple( StoreArgument{ source=RegisterArgument codeReg, offset=0, base=memAddr, index=ObjectIndex, kind=moveNativeWord, isMutable=false}) :: BlockSimple(LoadArgument{ source=MemoryLocation{offset=0, base=closureReg, index=ObjectIndex, cache=NONE}, dest=codeReg, kind=Move64Bit}) :: BlockSimple(LoadArgument{ source=AddressConstant(toMachineWord closureRef), dest=closureReg, kind=movePolyWord}) :: BlockSimple(AllocateMemoryOperation{size=n, flags=F_closure, dest=memAddr, saveRegs=[]}) :: tlCode end | loadFields(f :: rest, n, tlCode) = let (* Defer the evaluation if possible. We may have a constant that we can't move directly but it's better to load it after the allocation otherwise we will have to push the register if we need to GC. *) val (code1, source1, _) = codeToICodeRev(BICExtract f, context, false, Allowed allowDefer, tlCode) val restAndAlloc = loadFields(rest, n+1, code1) val (code2, source, _) = moveIfNotAllowedRev(Allowed allowInMemMove, restAndAlloc, source1) val storeValue = BlockSimple(StoreArgument{ source=source, offset=n*Word.toInt wordSize, base=memAddr, index=ObjectIndex, kind=movePolyWord, isMutable=false}) in storeValue :: code2 end val code = BlockSimple InitialisationComplete :: BlockSimple(LoadArgument{source=RegisterArgument memAddr, dest=target, kind=movePolyWord}) :: loadFields(closure, 2, tailCode) in (code, RegisterArgument target, false) end (* Treat it as a tuple with the code as the first field. *) else codeToICodeRev(BICTuple(BICConstnt(codeAddressFromClosure closureRef, []) :: map BICExtract closure), context, isTail, destination, tailCode) end | codeToICodeRev(BICCond(test, thenPt, elsePt), context, isTail, NoResult, tailCode) = let (* If we don't want the result but are only evaluating for side-effects we may be able to optimise special cases. This was easier in the forward case but for now we don't bother and leave it to the lower levels. *) val startElse = newLabel() and skipElse = newLabel() val codeTest = codeConditionRev(test, context, false, startElse, tailCode) val (codeThen, _, _) = codeToICodeRev(thenPt, context, isTail, NoResult, codeTest) val (codeElse, _, _) = codeToICodeRev(elsePt, context, isTail, NoResult, BlockLabel startElse :: BlockFlow(Unconditional skipElse) :: codeThen) in (BlockLabel skipElse :: codeElse, (* Unit result *) IntegerConstant(tag 0), false) end | codeToICodeRev(BICCond(test, thenPt, elsePt), context, isTail, destination, tailCode) = let (* Because we may push the result onto the stack we have to create a new preg to hold the result and then copy that to the final result. *) (* If this is a tail each arm will exit separately and neither will return a result. *) val target = asTarget destination val condResult = newMergeReg() val thenTarget = if isTail then newPReg() else condResult val startElse = newLabel() val testCode = codeConditionRev(test, context, false, startElse, tailCode) (* Put the result in the target register. *) val (thenCode, _, thenExited) = codeToICodeRev(thenPt, context, isTail, SpecificPReg thenTarget, testCode) (* Add a jump round the else-part except that if this is a tail we return. The then-part could have exited e.g. with a raise or a loop. *) val (exitThen, thenLabel, elseTarget) = if thenExited then (thenCode, [], target (* Can use original target. *)) else if isTail then (returnInstruction(context, thenTarget, thenCode), [], newPReg()) else let val skipElse = newLabel() in (BlockFlow(Unconditional skipElse) :: thenCode, [BlockSimple(LoadArgument{source=RegisterArgument condResult, dest=target, kind=movePolyWord}), BlockLabel skipElse], condResult) end val (elseCode, _, elseExited) = codeToICodeRev(elsePt, context, isTail, SpecificPReg elseTarget, BlockLabel startElse :: exitThen) (* Add a return to the else-part if necessary so we will always exit on a tail. *) val exitElse = if isTail andalso not elseExited then returnInstruction(context, elseTarget, elseCode) else elseCode in (thenLabel @ exitElse, RegisterArgument target, isTail orelse thenExited andalso elseExited) end | codeToICodeRev(BICCase { cases, test, default, isExhaustive, firstIndex}, context, isTail, destination, tailCode) = let (* We have to create a new preg for the result in case we need to push it to the stack. *) val targetReg = newMergeReg() local val initialTestReg = newPReg() val (testCode, _, _) = codeToICodeRev(test, context, false, SpecificPReg initialTestReg, tailCode) (* Subtract the minimum value so the value we're testing is always in the range of (tagged) 0 to the maximum. It is possible to adjust the value when computing the index but that can lead to overflows during compilation if the minimum is very large or small. We can ignore overflow and allow values to wrap round. *) in val (testCode, testReg) = if firstIndex = 0w0 then (testCode, initialTestReg) else let val newTestReg = newPReg() val subtract = BlockSimple(ArithmeticFunction{oper=SUB, resultReg=newTestReg, operand1=initialTestReg, operand2=IntegerConstant(semitag(Word.toLargeInt firstIndex)), ccRef=newCCRef(), opSize=polyWordOpSize}) in (subtract :: testCode, newTestReg) end end val workReg = newPReg() (* Unless this is exhaustive we need to add a range check. *) val (rangeCheck, extraDefaults) = if isExhaustive then (testCode, []) else let val defLab1 = newLabel() val tReg1 = newPReg() val ccRef1 = newCCRef() (* Since we've subtracted any minimum we only have to check whether the value is greater (unsigned) than the maximum. *) val numberOfCases = LargeInt.fromInt(List.length cases) val continueLab = newLabel() val testCode2 = BlockLabel continueLab :: BlockFlow(Conditional{ccRef=ccRef1, condition=JNB, trueJump=defLab1, falseJump=continueLab}) :: BlockSimple(WordComparison{arg1=tReg1, arg2=IntegerConstant(tag numberOfCases), ccRef=ccRef1, opSize=polyWordOpSize}) :: BlockSimple(LoadArgument {source=RegisterArgument testReg, dest=tReg1, kind=movePolyWord}) :: testCode in (testCode2, [defLab1]) end (* Make a label for each item in the list. *) val codeLabels = map (fn _ => newLabel()) cases (* Create an exit label in case it's needed. *) val labelForExit = if isTail then ~1 (* Illegal label. *) else newLabel() (* Generate the code for each of the cases and the default. We need to put an unconditional branch after each to skip the other cases. *) fun codeCases (SOME c :: otherCases, startLabel :: otherLabels, tailCode) = let val caseTarget = if isTail then newPReg() else targetReg (* Put in the case with a jump to the end of the sequence. *) val (codeThisCase, _, caseExited) = codeToICodeRev(c, context, isTail, SpecificPReg caseTarget, BlockLabel startLabel :: tailCode) val exitThisCase = if caseExited then codeThisCase else if isTail then returnInstruction(context, caseTarget, codeThisCase) else BlockFlow(Unconditional labelForExit) :: codeThisCase in codeCases(otherCases, otherLabels, exitThisCase) end | codeCases(NONE :: otherCases, _ :: otherLabels, tailCode) = codeCases(otherCases, otherLabels, tailCode) | codeCases ([], [], tailCode) = let (* We need to add labels for all the gaps we filled and also for a "default" label for the indexed-case instruction itself as well as any range checks. *) fun addDefault (startLabel, NONE, l) = BlockLabel startLabel :: l | addDefault (_, SOME _, l) = l fun asForward l = BlockLabel l val dLabs = map asForward extraDefaults @ tailCode val defLabels = ListPair.foldlEq addDefault dLabs (codeLabels, cases) val defaultTarget = if isTail then newPReg() else targetReg val (defaultCode, _, defaultExited) = codeToICodeRev(default, context, isTail, SpecificPReg defaultTarget, defLabels) in (* Put in the default. Because this is the last we don't need to jump round it. However if this is a tail and we haven't exited we put in a return. That way the case will always have exited if this is a tail. *) if isTail andalso not defaultExited then returnInstruction(context, defaultTarget, defaultCode) else defaultCode end | codeCases _ = raise InternalError "codeCases: mismatch" val codedCases = codeCases(cases, codeLabels, BlockFlow(IndexedBr codeLabels) :: BlockSimple(IndexedCaseOperation{testReg=testReg, workReg=workReg}) :: rangeCheck) (* We can now copy to the target. If we need to push the result this load will be converted into a push. *) val target = asTarget destination val copyToTarget = if isTail then codedCases else BlockSimple(LoadArgument{source=RegisterArgument targetReg, dest=target, kind=movePolyWord}) :: BlockLabel labelForExit :: codedCases in (copyToTarget, RegisterArgument target, isTail (* We have always exited on a tail. *)) end | codeToICodeRev(BICBeginLoop {loop, arguments}, context as { stackPtr, currHandler, overflowBlock, ...}, isTail, destination, tailCode) = let val target = asTarget destination fun codeArgs ([], tailCode) = ([], tailCode) | codeArgs (({value, addr}, _) :: rest, tailCode) = let val pr = newPReg() val () = Array.update(locToPregArray, addr, PregLocation pr) val (code, _, _) = codeToICodeRev(value, context, false, SpecificPReg pr, tailCode) val (pregs, othercode) = codeArgs(rest, code) in (pr::pregs, othercode) end val (loopRegs, argCode) = codeArgs(arguments, tailCode) val loopLabel = newLabel() val (loopBody, _, loopExited) = codeToICodeRev(loop, {loopArgs=SOME (loopRegs, loopLabel, stackPtr), stackPtr=stackPtr, currHandler=currHandler, overflowBlock=overflowBlock }, isTail, SpecificPReg target, BlockLabel loopLabel :: BlockSimple BeginLoop :: argCode) in (loopBody, RegisterArgument target, loopExited) end | codeToICodeRev(BICLoop args, context as {loopArgs=SOME (loopRegs, loopLabel, loopSp), stackPtr, currHandler, ...}, _, destination, tailCode) = let val target = asTarget destination (* Registers to receive the evaluated arguments. We can't put the values into the loop variables yet because the values could depend on the current values of the loop variables. *) val argPRegs = map(fn _ => newPReg()) args val codeArgs = ListPair.foldlEq(fn ((arg, _), pr, l) => #1 (codeToICodeRev(arg, context, false, SpecificPReg pr, l))) tailCode (args, argPRegs) val jumpArgs = ListPair.mapEq(fn (s, l) => (RegisterArgument s, l)) (argPRegs, loopRegs) (* If we've allocated a container in the loop we have to remove it before jumping back. *) val stackReset = if loopSp = stackPtr then codeArgs else BlockSimple(ResetStackPtr{numWords=stackPtr-loopSp, preserveCC=false}) :: codeArgs val jumpLoop = JumpLoop{regArgs=jumpArgs, stackArgs=[], checkInterrupt=SOME[], workReg=NONE} (* "checkInterrupt" could result in a Interrupt exception so we treat this like a function call. *) val code = case currHandler of NONE => BlockFlow(Unconditional loopLabel) :: BlockSimple jumpLoop :: stackReset | SOME h => BlockOptionalHandle{call=jumpLoop, handler=h, label=loopLabel} :: stackReset in (code, RegisterArgument target, true) end | codeToICodeRev(BICLoop _, {loopArgs=NONE, ...}, _, _, _) = raise InternalError "BICLoop without BICBeginLoop" | codeToICodeRev(BICRaise exc, context as { currHandler, ...}, _, destination, tailCode) = let val packetReg = newPReg() val (code, _, _) = codeToICodeRev(exc, context, false, SpecificPReg packetReg, tailCode) val raiseCode = RaiseExceptionPacket{packetReg=packetReg} val block = case currHandler of NONE => BlockExit raiseCode | SOME h => BlockRaiseAndHandle(raiseCode, h) in (block :: code, RegisterArgument(asTarget destination), true (* Always exits *)) end | codeToICodeRev(BICHandle{exp, handler, exPacketAddr}, context as { stackPtr, loopArgs, overflowBlock, ... }, isTail, destination, tailCode) = let (* As with BICCond and BICCase we need to create a new register for the result in case we need to push it to the stack. *) val handleResult = newMergeReg() val handlerLab = newLabel() and startHandling = newLabel() val (bodyTarget, handlerTarget) = if isTail then (newPReg(), newPReg()) else (handleResult, handleResult) (* TODO: Even if we don't actually want a result we force one in here by using "asTarget". *) (* The expression cannot be treated as a tail because the handler has to be removed after. It may "exit" if it has raised an unconditional exception. If it has we mustn't generate a PopExceptionHandler because there won't be any result for resultReg. We need to add two words to the stack to account for the items pushed by PushExceptionHandler. We create an instruction to push the handler followed by a block fork to the start of the code and, potentially the handler, then a label to start the code that the handler is in effect for. *) val initialCode = BlockLabel startHandling :: BlockFlow(SetHandler{handler=handlerLab, continue=startHandling}) :: BlockSimple(PushExceptionHandler{workReg=newPReg()}) :: tailCode val (expCode, _, expExit) = codeToICodeRev(exp, {stackPtr=stackPtr+2, loopArgs=loopArgs, currHandler=SOME handlerLab, overflowBlock=overflowBlock}, false (* Not tail *), SpecificPReg bodyTarget, initialCode) (* If this is the tail we can replace the jump at the end of the handled code with returns. If the handler has exited we don't need a return there. Otherwise we need to add an unconditional jump to skip the handler. *) val (atExpEnd, skipExpLabel) = case (isTail, expExit) of (true, true) => (* Tail and exited. *) (expCode, NONE) | (true, false) => (* Tail and not exited. *) (returnInstruction(context, bodyTarget, BlockSimple(PopExceptionHandler{workReg=newPReg()}) :: expCode), NONE) | (false, true) => (* Not tail but exited. *) (expCode, NONE) | (false, false) => let val skipHandler = newLabel() in (BlockFlow(Unconditional skipHandler) :: BlockSimple(PopExceptionHandler{workReg=newPReg()}) :: expCode, SOME skipHandler) end (* Make a register to hold the exception packet and put eax into it. *) val packetAddr = newPReg() val () = Array.update(locToPregArray, exPacketAddr, PregLocation packetAddr) val (handleCode, _, handleExit) = codeToICodeRev(handler, context, isTail, SpecificPReg handlerTarget, BlockSimple(BeginHandler{workReg=newPReg(), packetReg=packetAddr}) :: BlockLabel handlerLab :: atExpEnd) val target = asTarget destination val afterHandler = case (isTail, handleExit) of (true, true) => (* Tail and exited. *) handleCode | (true, false) => (* Tail and not exited. *) returnInstruction(context, handlerTarget, handleCode) | (false, _) => (* Not tail. *) handleCode val addLabel = case skipExpLabel of SOME lab => BlockLabel lab:: afterHandler | NONE => afterHandler in (BlockSimple(LoadArgument{source=RegisterArgument handleResult, dest=target, kind=movePolyWord}) :: addLabel, RegisterArgument target, isTail) end | codeToICodeRev(BICTuple fields, context, _, destination, tailCode) = let (* TODO: This is a relic of the old fall-back code-generator. It required the result of a tuple to be at the top of the stack. It should be changed. *) val target = asTarget destination (* Actually we want this. *) val memAddr = newPReg() fun loadFields([], n, tlCode) = BlockSimple(AllocateMemoryOperation{size=n, flags=0w0, dest=memAddr, saveRegs=[]}) :: tlCode | loadFields(f :: rest, n, tlCode) = let (* Defer the evaluation if possible. We may have a constant that we can't move directly but it's better to load it after the allocation otherwise we will have to push the register if we need to GC. *) val (code1, source1, _) = codeToICodeRev(f, context, false, Allowed allowDefer, tlCode) val restAndAlloc = loadFields(rest, n+1, code1) val (code2, source, _) = moveIfNotAllowedRev(Allowed allowInMemMove, restAndAlloc, source1) val storeValue = BlockSimple(StoreArgument{ source=source, offset=n*Word.toInt wordSize, base=memAddr, index=memIndexOrObject, kind=movePolyWord, isMutable=false}) in storeValue :: code2 end val code = BlockSimple InitialisationComplete :: BlockSimple(LoadArgument{source=RegisterArgument memAddr, dest=target, kind=movePolyWord}) :: loadFields(fields, 0, tailCode) in (code, RegisterArgument target, false) end (* Copy the source tuple into the container. There are important special cases for both the source tuple and the container. If the source tuple is a BICTuple we have the fields and can store them without creating a tuple on the heap. If the destination is a local container we can store directly into the stack. *) | codeToICodeRev(BICSetContainer{container, tuple, filter}, context as {stackPtr, ...}, _, destination, tailCode) = let local fun createStore containerReg (source, destWord) = StoreArgument{source=source, offset=destWord*Word.toInt nativeWordSize, base=containerReg, index=NoMemIndex, kind=moveNativeWord, isMutable=false} in val findContainer = case container of BICExtract(BICLoadLocal l) => ( case Array.sub(locToPregArray, l) of ContainerLocation{container, stackOffset} => let fun storeToStack(source, destWord) = StoreToStack{source=source, container=container, field=destWord, stackOffset=stackPtr-stackOffset+destWord} in SOME storeToStack end | _ => NONE ) | _ => NONE val (codeContainer, storeInstr) = case findContainer of SOME storeToStack => (tailCode, storeToStack) | NONE => let val containerTarget = newPReg() val (codeContainer, _, _) = codeToICodeRev(container, context, false, SpecificPReg containerTarget, tailCode) in (codeContainer, createStore containerTarget) end end val filterLength = BoolVector.length filter val code = case tuple of BICTuple cl => let (* In theory it's possible that the tuple could contain fields that are not used but nevertheless need to be evaluated for their side-effects. Create all the fields and push to the stack. *) fun codeField(arg, (regs, tailCode)) = let val (c, r, _) = codeToICodeRev(arg, context, false, Allowed allowInMemMove, tailCode) in (r :: regs, c) end val (pregsRev, codeFields) = List.foldl codeField ([], codeContainer) cl val pregs = List.rev pregsRev fun copyField(srcReg, (sourceWord, destWord, tailCode)) = if sourceWord < filterLength andalso BoolVector.sub(filter, sourceWord) then (sourceWord+1, destWord+1, BlockSimple(storeInstr(srcReg, destWord)) :: tailCode) else (sourceWord+1, destWord, tailCode) val (_, _, resultCode) = List.foldl copyField (0, 0, codeFields) pregs in resultCode end | tuple => let (* Copy a heap tuple. It is possible that this is another container in which case we must load the fields directly. We mustn't load its address and then copy because loading the address would be the last reference and might cause the container to be reused prematurely. *) val findContainer = case tuple of BICExtract(BICLoadLocal l) => ( case Array.sub(locToPregArray, l) of ContainerLocation{container, stackOffset} => let fun getAddr sourceWord = StackLocation{wordOffset=stackPtr-stackOffset+sourceWord, container=container, field=sourceWord, cache=NONE} in SOME getAddr end | _ => NONE ) | _ => NONE val (codeTuple, loadField) = case findContainer of SOME getAddr => (codeContainer, getAddr) | NONE => let val tupleTarget = newPReg() val (codeTuple, _, _) = codeToICodeRev(tuple, context, false, SpecificPReg tupleTarget, codeContainer) fun loadField sourceWord = wordOffsetAddress(sourceWord, tupleTarget) in (codeTuple, loadField) end fun copyContainer(sourceWord, destWord, tailCode) = if sourceWord = filterLength then tailCode else if BoolVector.sub(filter, sourceWord) then let val loadReg = newPReg() val code = BlockSimple(storeInstr(RegisterArgument loadReg, destWord)) :: BlockSimple(LoadArgument{source=loadField sourceWord, dest=loadReg, kind=movePolyWord}) :: tailCode in copyContainer(sourceWord+1, destWord+1, code) end else copyContainer(sourceWord+1, destWord, tailCode) in copyContainer(0, 0, codeTuple) end in moveIfNotAllowedRev(destination, code, (* Unit result *) IntegerConstant(tag 0)) end | codeToICodeRev(BICTagTest{test, tag=tagValue, ...}, context, _, destination, tailCode) = (* Check the "tag" word of a union (datatype). N.B. Not the same as testing the tag bit of a word. *) let val ccRef = newCCRef() val memOrReg = { anyConstant=false, const32s=false, memAddr=true, existingPreg=true } val (testCode, tagArg, _) = codeToICodeRev(test, context, false, Allowed memOrReg, tailCode) val target = asTarget destination in (makeBoolResultRev(JE, ccRef, target, (* Use CompareLiteral because the tag must fit in 32-bits. *) BlockSimple(CompareLiteral{arg1=tagArg, arg2=tag(Word.toLargeInt tagValue), opSize=polyWordOpSize, ccRef=ccRef}) :: testCode), RegisterArgument target, false) end | codeToICodeRev(BICLoadOperation instr, context, isTail, destination, tailCode) = let val (code, dest, haveExited) = codeToICodeLoad(instr, context, isTail, destination) in (revApp(code, tailCode), dest, haveExited) end | codeToICodeRev(BICStoreOperation instr, context, isTail, destination, tailCode) = let val (code, dest, haveExited) = codeToICodeStore(instr, context, isTail, destination) in (revApp(code, tailCode), dest, haveExited) end | codeToICodeRev(BICBlockOperation ({kind=BlockOpEqualByte, sourceLeft, destRight, length}), context, _, destination, tailCode) = let val vec1Reg = newUReg() and vec2Reg = newUReg() val ccRef = newCCRef() val (leftCode, leftUntag, {base=leftBase, offset=leftOffset, index=leftIndex, ...}) = codeAddressRev(sourceLeft, true, context, tailCode) val (rightCode, rightUntag, {base=rightBase, offset=rightOffset, index=rightIndex, ...}) = codeAddressRev(destRight, true, context, leftCode) val (lengthCode, lengthUntag, lengthArg) = codeAsUntaggedToRegRev(length, false (* unsigned *), context, rightCode) val target = asTarget destination val code = makeBoolResultRev(JE, ccRef, target, BlockSimple(CompareByteVectors{ vec1Addr=vec1Reg, vec2Addr=vec2Reg, length=lengthArg, ccRef=ccRef }) :: lengthUntag @ BlockSimple(loadAddress{base=rightBase, offset=rightOffset, index=rightIndex, dest=vec2Reg}) :: rightUntag @ BlockSimple(loadAddress{base=leftBase, offset=leftOffset, index=leftIndex, dest=vec1Reg}) :: leftUntag @ lengthCode) in (code, RegisterArgument target, false) end | codeToICodeRev(BICBlockOperation instr, context, isTail, destination, tailCode) = let val (code, dest, haveExited) = codeToICodeBlock(instr, context, isTail, destination) in (revApp(code, tailCode), dest, haveExited) end and codeToICodeUnaryRev({oper=BuiltIns.NotBoolean, arg1}, context, _, destination, tailCode) = let val target = asTarget destination val ccRef = newCCRef() val allow = Allowed {anyConstant=false, const32s=false, memAddr=true, existingPreg=true} val (argCode, testDest, _) = codeToICodeRev(arg1, context, false, allow, tailCode) in (* Test the argument and return a boolean result. If either the argument is a condition or the result is used in a test this will be better than using XOR. *) (makeBoolResultRev(JNE, ccRef, target, BlockSimple(CompareLiteral{arg1=testDest, arg2=tag 1, opSize=polyWordOpSize, ccRef=ccRef}) :: argCode), RegisterArgument target, false) end | codeToICodeUnaryRev({oper=BuiltIns.IsTaggedValue, arg1}, context, _, destination, tailCode) = let val ccRef = newCCRef() val memOrReg = { anyConstant=false, const32s=false, memAddr=true, existingPreg=true } val (testCode, testResult, _) = codeToICodeRev(arg1, context, false, Allowed memOrReg, tailCode) (* Test the tag bit. This sets the zero bit if the value is untagged. *) val target = asTarget destination in (makeBoolResultRev(JNE, ccRef, target, BlockSimple(TestTagBit{arg=testResult, ccRef=ccRef}) :: testCode), RegisterArgument target, false) end | codeToICodeUnaryRev({oper=BuiltIns.MemoryCellLength, arg1}, context, _, destination, tailCode) = let val target = asTarget destination val argReg1 = newUReg() and argReg2 = newUReg() and argReg3 = newUReg() (* These are untagged until the tag is put in. *) and ccRef1 = newCCRef() and ccRef2 = newCCRef() and ccRef3 = newCCRef() (* Get the length of a memory cell (heap object). We need to mask out the top byte containing the flags and to tag the result. The mask is 56 bits on 64-bit which won't fit in an inline constant. Since we have to shift it anyway we might as well do this by shifts. *) val (argCode, addrReg) = codeToPRegRev(arg1, context, tailCode) in (BlockSimple(ArithmeticFunction{oper=OR, resultReg=target, operand1=argReg3, operand2=IntegerConstant 1, ccRef=ccRef3, opSize=polyWordOpSize}) :: BlockSimple(ShiftOperation{shift=SHR, resultReg=argReg3, operand=argReg2, shiftAmount=IntegerConstant 7 (* 8-tagshift*), ccRef=ccRef2, opSize=polyWordOpSize }) :: BlockSimple(ShiftOperation{shift=SHL, resultReg=argReg2, operand=argReg1, shiftAmount=IntegerConstant 8, ccRef=ccRef1, opSize=polyWordOpSize }) :: BlockSimple(LoadArgument{source=wordOffsetAddress(~1, addrReg), dest=argReg1, kind=movePolyWord}) :: argCode, RegisterArgument target, false) end | codeToICodeUnaryRev({oper=BuiltIns.MemoryCellFlags, arg1}, context, _, destination, tailCode) = let val target = asTarget destination val argReg1 = newUReg() val (argCode, addrReg) = codeToPRegRev(arg1, context, tailCode) in (BlockSimple(TagValue{ source=argReg1, dest=target, isSigned=false, opSize=OpSize32 }) :: BlockSimple(LoadArgument{source=MemoryLocation{offset= ~1, base=addrReg, index=memIndexOrObject, cache=NONE}, dest=argReg1, kind=MoveByte}) :: argCode, RegisterArgument target, false) end | codeToICodeUnaryRev({oper=BuiltIns.ClearMutableFlag, arg1}, context, _, destination, tailCode) = let val (argCode, addrReg) = codeToPRegRev(arg1, context, tailCode) in moveIfNotAllowedRev(destination, BlockSimple(LockMutable{addr=addrReg}) :: argCode, (* Unit result *) IntegerConstant(tag 0)) end | codeToICodeUnaryRev({oper=BuiltIns.AtomicIncrement, arg1}, context, _, destination, tailCode) = let val target = asTarget destination val incrReg = newUReg() val (argCode, addrReg) = codeToPRegRev(arg1, context, tailCode) val code = (* We want the result to be the new value but we've returned the old value. *) BlockSimple(ArithmeticFunction{oper=ADD, resultReg=target, operand1=incrReg, operand2=IntegerConstant(semitag 1), ccRef=newCCRef(), opSize=polyWordOpSize}) :: BlockSimple(AtomicExchangeAndAdd{ base=addrReg, source=incrReg }) :: BlockSimple(LoadArgument{source=IntegerConstant(semitag 1), dest=incrReg, kind=movePolyWord}) :: argCode in (code, RegisterArgument target, false) end | codeToICodeUnaryRev({oper=BuiltIns.AtomicDecrement, arg1}, context, _, destination, tailCode) = let val target = asTarget destination val incrReg = newUReg() val (argCode, addrReg) = codeToPRegRev(arg1, context, tailCode) val code = BlockSimple(ArithmeticFunction{oper=SUB, resultReg=target, operand1=incrReg, operand2=IntegerConstant(semitag 1), ccRef=newCCRef(), opSize=polyWordOpSize}) :: BlockSimple(AtomicExchangeAndAdd{ base=addrReg, source=incrReg }) :: BlockSimple(LoadArgument{source=IntegerConstant(semitag ~1), dest=incrReg, kind=movePolyWord}) :: argCode in (code, RegisterArgument target, false) end | codeToICodeUnaryRev({oper=BuiltIns.AtomicReset, arg1}, context, _, destination, tailCode) = let (* This is needed only for the interpreted version where we have a single real mutex to interlock atomic increment and decrement. We have to use the same mutex to interlock clearing a mutex. On the X86 we use hardware locking and the hardware guarantees that an assignment of a word will be atomic. *) val (argCode, addrReg) = codeToPRegRev(arg1, context, tailCode) (* Store tagged 0 in the mutex. This is the unlocked value. *) val code = BlockSimple(StoreArgument{source=IntegerConstant(tag 0), base=addrReg, index=memIndexOrObject, offset=0, kind=movePolyWord, isMutable=true}) :: argCode in moveIfNotAllowedRev(destination, code, (* Unit result *) IntegerConstant(tag 0)) end | codeToICodeUnaryRev({oper=BuiltIns.LongWordToTagged, arg1}, context, _, destination, tailCode) = let (* This is exactly the same as StringLengthWord at the moment. TODO: introduce a new ICode entry so that the next stage can optimise longword operations. *) val target = asTarget destination val argReg1 = newUReg() val (argCode, addrReg) = codeToPRegRev(arg1, context, tailCode) val code = BlockSimple(TagValue{ source=argReg1, dest=target, isSigned=false, opSize=polyWordOpSize }) :: (* Use movePolyWord even on 32-in-64 since we're producing a 32-bit value anyway. *) BlockSimple(LoadArgument{source=wordAt addrReg, dest=argReg1, kind=movePolyWord}) :: argCode in (code, RegisterArgument target, false) end | codeToICodeUnaryRev({oper=BuiltIns.SignedToLongWord, arg1}, context, _, destination, tailCode) = let val addrReg = newPReg() and untagArg = newUReg() val (argCode, argReg1) = codeToPRegRev(arg1, context, tailCode) val (signExtend, sxReg) = case targetArch of ObjectId32Bit => let val sReg = newUReg() in ([BlockSimple(SignExtend32To64{source=RegisterArgument argReg1, dest=sReg})], sReg) end | _ => ([], argReg1) val code = BlockSimple(BoxValue{boxKind=BoxLargeWord, source=untagArg, dest=addrReg, saveRegs=[]}) :: BlockSimple(UntagValue{source=sxReg, dest=untagArg, isSigned=true, cache=NONE, opSize=nativeWordOpSize}) :: signExtend @ argCode in moveIfNotAllowedRev(destination, code, RegisterArgument addrReg) end | codeToICodeUnaryRev({oper=BuiltIns.UnsignedToLongWord, arg1}, context, _, destination, tailCode) = let val addrReg = newPReg() and untagArg = newUReg() val (argCode, argReg1) = codeToPRegRev(arg1, context, tailCode) val code = BlockSimple(BoxValue{boxKind=BoxLargeWord, source=untagArg, dest=addrReg, saveRegs=[]}) :: (* We can just use a polyWord operation to untag the unsigned value. *) BlockSimple(UntagValue{source=argReg1, dest=untagArg, isSigned=false, cache=NONE, opSize=polyWordOpSize}) :: argCode in moveIfNotAllowedRev(destination, code, RegisterArgument addrReg) end | codeToICodeUnaryRev({oper=BuiltIns.RealNeg precision, arg1}, context, _, destination, tailCode) = let val target = asTarget destination val fpRegSrc = newUReg() and fpRegDest = newUReg() and sse2ConstReg = newUReg() (* The SSE2 code uses an SSE2 logical operation to flip the sign bit. This requires the values to be loaded into registers first because the logical operations require 128-bit operands. *) val (argCode, aReg1) = codeToPReg(arg1, context) (* Double precision values are always boxed and single precision values if they won't fit in a word. Otherwise we can using tagging. *) open BuiltIns val load = if precision = PrecDouble then BlockSimple(LoadArgument{source=wordAt aReg1, dest=fpRegSrc, kind=MoveDouble}) else if wordSize = 0w8 then BlockSimple(UntagFloat{source=RegisterArgument aReg1, dest=fpRegSrc, cache=NONE}) else BlockSimple(LoadArgument{source=wordAt aReg1, dest=fpRegSrc, kind=MoveFloat}) val code = case fpMode of FPModeX87 => [BlockSimple(X87FPUnaryOps{ fpOp=FCHS, dest=fpRegDest, source=fpRegSrc})] | FPModeSSE2 => let (* In single precision mode the sign bit is in the low 32-bits. There may be a better way to load it. *) val signBit = if precision = PrecDouble then realSignBit else floatSignBit in [BlockSimple(LoadArgument{source=AddressConstant signBit, dest=sse2ConstReg, kind=MoveDouble}), BlockSimple(SSE2FPBinary{opc=SSE2BXor, resultReg=fpRegDest, arg1=fpRegSrc, arg2=RegisterArgument sse2ConstReg})] end val result = boxOrTagReal(fpRegDest, target, precision) in (revApp(argCode @ load :: code @ result, tailCode), RegisterArgument target, false) end | codeToICodeUnaryRev({oper=BuiltIns.RealAbs precision, arg1}, context, _, destination, tailCode) = let val target = asTarget destination val fpRegSrc = newUReg() and fpRegDest = newUReg() and sse2ConstReg = newUReg() val (argCode, aReg1) = codeToPReg(arg1, context) open BuiltIns val load = if precision = PrecDouble then BlockSimple(LoadArgument{source=wordAt aReg1, dest=fpRegSrc, kind=MoveDouble}) else if wordSize = 0w8 then BlockSimple(UntagFloat{source=RegisterArgument aReg1, dest=fpRegSrc, cache=NONE}) else BlockSimple(LoadArgument{source=wordAt aReg1, dest=fpRegSrc, kind=MoveFloat}) val code = case fpMode of FPModeX87 => [BlockSimple(X87FPUnaryOps{ fpOp=FABS, dest=fpRegDest, source=fpRegSrc})] | FPModeSSE2 => let val mask = if precision = PrecDouble then realAbsMask else floatAbsMask in [BlockSimple(LoadArgument{source=AddressConstant mask, dest=sse2ConstReg, kind=MoveDouble}), BlockSimple(SSE2FPBinary{opc=SSE2BAnd, resultReg=fpRegDest, arg1=fpRegSrc, arg2=RegisterArgument sse2ConstReg})] end val result = boxOrTagReal(fpRegDest, target, precision) in (revApp(argCode @ load :: code @ result, tailCode), RegisterArgument target, false) end | codeToICodeUnaryRev({oper=BuiltIns.RealFixedInt precision, arg1}, context, _, destination, tailCode) = let val target = asTarget destination val untagReg = newUReg() and fpReg = newUReg() val (argCode, aReg1) = codeToPReg(arg1, context) val floatOp = case fpMode of FPModeX87 => X87Float | FPModeSSE2 => SSE2Float val boxFloat = case fpMode of FPModeX87 => BoxX87Double | FPModeSSE2 => BoxSSE2Double val _ = precision = BuiltIns.PrecDouble orelse raise InternalError "RealFixedInt - single" val code = argCode @ [BlockSimple(UntagValue{source=aReg1, dest=untagReg, isSigned=true, cache=NONE, opSize=polyWordOpSize}), BlockSimple(floatOp{ dest=fpReg, source=RegisterArgument untagReg}), BlockSimple(BoxValue{boxKind=boxFloat, source=fpReg, dest=target, saveRegs=[]})] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeUnaryRev({oper=BuiltIns.FloatToDouble, arg1}, context, _, destination, tailCode) = let (* Convert a single precision floating point value to double precision. *) val target = asTarget destination val fpReg = newUReg() and fpReg2 = newUReg() val (argCode, aReg1) = codeToPReg(arg1, context) (* MoveFloat always converts from single to double-precision. *) val unboxOrUntag = case (fpMode, wordSize) of (FPModeX87, _) => [BlockSimple(LoadArgument{source=wordAt aReg1, dest=fpReg2, kind=MoveFloat})] | (FPModeSSE2, 0w4) => [BlockSimple(LoadArgument{source=wordAt aReg1, dest=fpReg, kind=MoveFloat}), BlockSimple(SSE2FPUnary{opc=SSE2UFloatToDouble, resultReg=fpReg2, source=RegisterArgument fpReg})] | (FPModeSSE2, _) => [BlockSimple(UntagFloat{source=RegisterArgument aReg1, dest=fpReg, cache=NONE}), BlockSimple(SSE2FPUnary{opc=SSE2UFloatToDouble, resultReg=fpReg2, source=RegisterArgument fpReg})] val boxFloat = case fpMode of FPModeX87 => BoxX87Double | FPModeSSE2 => BoxSSE2Double val code = argCode @ unboxOrUntag @ [BlockSimple(BoxValue{boxKind=boxFloat, source=fpReg2, dest=target, saveRegs=[]})] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeUnaryRev({oper=BuiltIns.DoubleToFloat NONE, arg1}, context, _, destination, tailCode) = let (* Convert a double precision value to a single precision using the current rounding mode. This is simpler than setting the rounding mode and then restoring it. *) val target = asTarget destination val fpReg = newUReg() and fpReg2 = newUReg() val (argCode, aReg1) = codeToPReg(arg1, context) (* In 32-bit mode we need to box the float. In 64-bit mode we can tag it. *) val boxOrTag = case fpMode of FPModeX87 => [BlockSimple(BoxValue{boxKind=BoxX87Float, source=fpReg, dest=target, saveRegs=[]})] | FPModeSSE2 => BlockSimple(SSE2FPUnary{opc=SSE2UDoubleToFloat, resultReg=fpReg2, source=RegisterArgument fpReg}) :: boxOrTagReal(fpReg2, target, BuiltIns.PrecSingle) val code = argCode @ [BlockSimple(LoadArgument{source=wordAt aReg1, dest=fpReg, kind=MoveDouble})] @ boxOrTag in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeUnaryRev({oper=BuiltIns.DoubleToFloat (SOME rndMode), arg1}, context, _, destination, tailCode) = let (* Convert a double precision value to a single precision. The rounding mode is passed in explicitly. *) val target = asTarget destination val fpReg = newUReg() and fpReg2 = newUReg() val (argCode, aReg1) = codeToPReg(arg1, context) (* In 32-bit mode we need to box the float. In 64-bit mode we can tag it. *) (* We need to save the rounding mode before we change it and restore it afterwards. *) open IEEEReal fun doConversion() = case fpMode of FPModeX87 => (* Convert the value using the appropriate rounding. *) [BlockSimple(BoxValue{boxKind=BoxX87Float, source=fpReg, dest=target, saveRegs=[]})] | FPModeSSE2 => BlockSimple(SSE2FPUnary{opc=SSE2UDoubleToFloat, resultReg=fpReg2, source=RegisterArgument fpReg}) :: boxOrTagReal(fpReg2, target, BuiltIns.PrecSingle) val code = argCode @ [BlockSimple(LoadArgument{source=wordAt aReg1, dest=fpReg, kind=MoveDouble})] @ setAndRestoreRounding(rndMode, doConversion) in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeUnaryRev({oper=BuiltIns.RealToInt(precision, rndMode), arg1}, context, _, destination, tailCode) = let val target = asTarget destination val chkOverflow = newCCRef() val convResult = newUReg() and wrkReg2 = newUReg() (* Convert a floating point value to an integer. We need to raise overflow if the result is out of range. We first convert the value to 32/64 bits then tag it. An overflow can happen either because the real number does not fit in 32/64 bits or if it is not a 31/63 bit value. Fortunately, if the first conversion fails the result is a value that causes an overflow when we try it shift it so the check for overflow only needs to happen there. There is an SSE2 instruction that implements truncation (round to zero) directly but in other cases we need to set the rounding mode. *) val doConvert = case (fpMode, precision) of (FPModeX87, _) => let val fpReg = newUReg() val (argCode, aReg) = codeToPReg(arg1, context) fun doConvert() = [BlockSimple(X87RealToInt{source=fpReg, dest=convResult })] in argCode @ [BlockSimple(LoadArgument{source=wordAt aReg, dest=fpReg, kind=MoveDouble})] @ setAndRestoreRounding(rndMode, doConvert) end | (FPModeSSE2, BuiltIns.PrecDouble) => let val (argCode, argReg) = codeToPReg(arg1, context) fun doConvert() = [BlockSimple( SSE2RealToInt{source=wordAt argReg, dest=convResult, isDouble=true, isTruncate = rndMode = IEEEReal.TO_ZERO }) ] in argCode @ ( case rndMode of IEEEReal.TO_ZERO => doConvert() | _ => setAndRestoreRounding(rndMode, doConvert)) end | (FPModeSSE2, BuiltIns.PrecSingle) => let val (argCode, aReg) = codeToPReg(arg1, context) val fpReg = newUReg() fun doConvert() = [BlockSimple( SSE2RealToInt{source=RegisterArgument fpReg, dest=convResult, isDouble=false, isTruncate = rndMode = IEEEReal.TO_ZERO })] in argCode @ [BlockSimple(UntagFloat{source=RegisterArgument aReg, dest=fpReg, cache=NONE})] @ ( case rndMode of IEEEReal.TO_ZERO => doConvert() | _ => setAndRestoreRounding(rndMode, doConvert) ) end val checkAndTag = BlockSimple(ShiftOperation{ shift=SHL, resultReg=wrkReg2, operand=convResult, shiftAmount=IntegerConstant 1, ccRef=chkOverflow, opSize=polyWordOpSize}) :: checkOverflow context chkOverflow @ [BlockSimple(ArithmeticFunction{oper=ADD, resultReg=target, operand1=wrkReg2, operand2=IntegerConstant 1, ccRef = newCCRef(), opSize=polyWordOpSize})] in (revApp(doConvert @ checkAndTag, tailCode), RegisterArgument target, false) end | codeToICodeUnaryRev({oper=BuiltIns.TouchAddress, arg1}, context, _, destination, tailCode) = let (* Put the value in a register. This is not entirely necessary but ensures that if the value is a constant the constant will be included in the code. *) val (argCode, aReg) = codeToPRegRev(arg1, context, tailCode) in moveIfNotAllowedRev(destination, BlockSimple(TouchArgument{source=aReg}) :: argCode, (* Unit result *) IntegerConstant(tag 0)) end | codeToICodeUnaryRev({oper=BuiltIns.AllocCStack, arg1}, context, _, destination, tailCode) = (* Allocate space on the C stack. Assumes that the argument has already been aligned. *) let val target = asTarget destination val (argCode, untaggedArg) = case arg1 of BICConstnt(value, _) => (tailCode, IntegerConstant(Word.toLargeInt(toShort value)) (* Leave untagged *)) | _ => let val (argCode, aReg) = codeToPRegRev(arg1, context, tailCode) val arg1Untagged = newUReg() in ( BlockSimple(UntagValue{source=aReg, dest=arg1Untagged, isSigned=false, cache=NONE, opSize=polyWordOpSize}) :: argCode, RegisterArgument arg1Untagged ) end val argReg1 = newUReg() and resReg1 = newUReg() val code = BlockSimple(BoxValue{boxKind=BoxLargeWord, source=resReg1, dest=target, saveRegs=[]}) :: BlockSimple(StoreMemReg{offset=memRegCStackPtr, source=resReg1, kind=moveNativeWord}) :: BlockSimple(ArithmeticFunction{oper=SUB, resultReg=resReg1, operand1=argReg1, operand2=untaggedArg, ccRef=newCCRef(), opSize=nativeWordOpSize}) :: BlockSimple(LoadMemReg{offset=memRegCStackPtr, dest=argReg1, kind=moveNativeWord}) :: argCode in (code, RegisterArgument target, false) end and codeToICodeBinaryRev({oper=BuiltIns.WordComparison{test, isSigned}, arg1, arg2=BICConstnt(arg2Value, _)}, context, _, destination, tailCode) = let (* Comparisons. Because this is also used for pointer equality and even for exception matching it is perfectly possible that the argument could be an address. The higher levels used to generate this for pointer equality. *) val ccRef = newCCRef() val comparison = (* If the argument is a tagged value that will fit in 32-bits we can use the literal version. Use toLargeIntX here because the value will be sign-extended even if we're actually doing an unsigned comparison. *) if isShort arg2Value andalso is32bit(tag(Word.toLargeIntX(toShort arg2Value))) then let val allow = Allowed {anyConstant=false, const32s=false, memAddr=true, existingPreg=true} in (* We're often comparing with a character or a string length field that has to be untagged. In that case we can avoid loading it into a register and untagging it by doing the comparison directly. *) case arg1 of BICLoadOperation{kind=LoadStoreUntaggedUnsigned, address} => let val (codeBaseIndex, codeUntag, memLoc) = codeAddressRev(address, false, context, tailCode) val literal = Word.toLargeIntX(toShort arg2Value) in BlockSimple(CompareLiteral{arg1=MemoryLocation memLoc, arg2=literal, opSize=polyWordOpSize, ccRef=ccRef}) :: codeUntag @ codeBaseIndex end | BICLoadOperation{kind=LoadStoreMLByte _, address} => let val (codeBaseIndex, codeUntag, {base, index, offset, ...}) = codeAddressRev(address, true, context, tailCode) val _ = toShort arg2Value >= 0w0 andalso toShort arg2Value < 0w256 orelse raise InternalError "Compare byte not a byte" val literal = Word8.fromLargeWord(Word.toLargeWord(toShort arg2Value)) in BlockSimple(CompareByteMem{arg1={base=base, index=index, offset=offset}, arg2=literal, ccRef=ccRef}) :: codeUntag @ codeBaseIndex end | BICUnary({oper=BuiltIns.MemoryCellFlags, arg1}) => (* This occurs particularly in arbitrary precision comparisons. *) let val (baseCode, baseReg) = codeToPRegRev(arg1, context, tailCode) val _ = toShort arg2Value >= 0w0 andalso toShort arg2Value < 0w256 orelse raise InternalError "Compare memory cell not a byte" val literal = Word8.fromLargeWord(Word.toLargeWord(toShort arg2Value)) in BlockSimple(CompareByteMem{arg1={base=baseReg, index=memIndexOrObject, offset= ~1}, arg2=literal, ccRef=ccRef}) :: baseCode end | _ => let (* TODO: We could include rarer cases of tagging by looking at the code and seeing if it's a TagValue. *) val (testCode, testDest, _) = codeToICodeRev(arg1, context, false, allow, tailCode) val literal = tag(Word.toLargeIntX(toShort arg2Value)) in BlockSimple(CompareLiteral{arg1=testDest, arg2=literal, opSize=polyWordOpSize, ccRef=ccRef}) :: testCode end end else (* Addresses or larger values. We need to use a register comparison. *) let val (testCode, testReg) = codeToPRegRev(arg1, context, tailCode) val arg2Arg = constantAsArgument arg2Value in BlockSimple(WordComparison{arg1=testReg, arg2=arg2Arg, ccRef=ccRef, opSize=polyWordOpSize}) :: testCode end val target = asTarget destination in (makeBoolResultRev(testAsBranch(test, isSigned, true), ccRef, target, comparison), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.WordComparison{test, isSigned}, arg1=BICConstnt(arg1Value, _), arg2}, context, _, destination, tailCode) = let (* If we have the constant first we need to reverse the test so the first argument is a register. *) val ccRef = newCCRef() val comparison = if isShort arg1Value andalso is32bit(tag(Word.toLargeIntX(toShort arg1Value))) then let val allow = Allowed {anyConstant=false, const32s=false, memAddr=true, existingPreg=true} val (testCode, testDest, _) = codeToICodeRev(arg2, context, false, allow, tailCode) val literal = tag(Word.toLargeIntX(toShort arg1Value)) in BlockSimple(CompareLiteral{arg1=testDest, arg2=literal, opSize=polyWordOpSize, ccRef=ccRef}) :: testCode end else (* Addresses or larger values. We need to use a register comparison. *) let val (testCode, testReg) = codeToPRegRev(arg2, context, tailCode) val arg1Arg = constantAsArgument arg1Value in BlockSimple(WordComparison{arg1=testReg, arg2=arg1Arg, ccRef=ccRef, opSize=polyWordOpSize}) :: testCode end val target = asTarget destination in (makeBoolResultRev(testAsBranch(leftRightTest test, isSigned, true), ccRef, target, comparison), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.WordComparison {test, isSigned}, arg1, arg2}, context, _, destination, tailCode) = let val ccRef = newCCRef() val memOrReg = { anyConstant=false, const32s=false, memAddr=true, existingPreg=true } val (arg1Code, arg1Result, _) = codeToICodeRev(arg1, context, false, Allowed memOrReg, tailCode) val (arg2Code, arg2Result, _) = codeToICodeRev(arg2, context, false, Allowed memOrReg, arg1Code) val target = asTarget destination val code = case (arg1Result, arg2Result) of (RegisterArgument arg1Reg, arg2Result) => makeBoolResultRev(testAsBranch(test, isSigned, true), ccRef, target, BlockSimple(WordComparison{arg1=arg1Reg, arg2=arg2Result, ccRef=ccRef, opSize=polyWordOpSize}) :: arg2Code) | (arg1Result, RegisterArgument arg2Reg) => (* The second argument is in a register - switch the sense of the test. *) makeBoolResultRev(testAsBranch(leftRightTest test, isSigned, true), ccRef, target, BlockSimple(WordComparison{arg1=arg2Reg, arg2=arg1Result, ccRef=ccRef, opSize=polyWordOpSize}) :: arg2Code) | (arg1Result, arg2Result) => let (* Have to load an argument - pick the first. *) val arg1Reg = newPReg() in makeBoolResultRev(testAsBranch(test, isSigned, true), ccRef, target, BlockSimple(WordComparison{arg1=arg1Reg, arg2=arg2Result, ccRef=ccRef, opSize=polyWordOpSize}) :: BlockSimple(LoadArgument{source=arg1Result, dest=arg1Reg, kind=movePolyWord}) :: arg2Code) end in (code, RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.PointerEq, arg1, arg2}, context, isTail, destination, tailCode) = (* Equality of general values which can include pointers. This can be treated exactly as a word equality. It has to be analysed differently for indexed cases. *) codeToICodeBinaryRev({oper=BuiltIns.WordComparison{test=BuiltIns.TestEqual, isSigned=false}, arg1=arg1, arg2=arg2}, context, isTail, destination, tailCode) | codeToICodeBinaryRev({oper=BuiltIns.FixedPrecisionArith oper, arg1, arg2}, context, _, destination, tailCode) = let val target = asTarget destination val code = codeFixedPrecisionArith(oper, arg1, arg2, context, target, checkOverflow context) in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.WordArith BuiltIns.ArithAdd, arg1, arg2=BICConstnt(value, _)}, context, _, destination, tailCode) = let val target = asTarget destination (* If the argument is a constant we can subtract the tag beforehand. N.B. it is possible to have type-incorrect values in dead code. i.e. code that will never be executed because of a run-time check. *) val constVal = if isShort value then semitag(Word.toLargeIntX(toShort value)) else 0 val (arg1Code, aReg1) = codeToPRegRev(arg1, context, tailCode) in (BlockSimple(ArithmeticFunction{oper=ADD, resultReg=target, operand1=aReg1, operand2=IntegerConstant constVal, ccRef = newCCRef(), opSize=polyWordOpSize}) :: arg1Code, RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.WordArith BuiltIns.ArithAdd, arg1=BICConstnt(value, _), arg2}, context, _, destination, tailCode) = let val target = asTarget destination (* If the argument is a constant we can subtract the tag beforehand. Check for short - see comment above. *) val constVal = if isShort value then semitag(Word.toLargeIntX(toShort value)) else 0 val (arg2Code, aReg2) = codeToPRegRev(arg2, context, tailCode) in (BlockSimple(ArithmeticFunction{oper=ADD, resultReg=target, operand1=aReg2, operand2=IntegerConstant constVal, ccRef = newCCRef(), opSize=polyWordOpSize}) :: arg2Code, RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.WordArith BuiltIns.ArithAdd, arg1, arg2}, context, _, destination, tailCode) = let val target = asTarget destination val (arg1Code, aReg1) = codeToPReg(arg1, context) val (arg2Code, aReg2) = codeToPReg(arg2, context) (* Use LEA to do the addition since we're not concerned with overflow. This is shorter than subtracting the tag and adding the values and also moves the result into the appropriate register. *) val code = arg1Code @ arg2Code @ [BlockSimple(LoadEffectiveAddress{base=SOME aReg1, offset= ~1, index=MemIndex1 aReg2, dest=target, opSize=polyWordOpSize})] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.WordArith BuiltIns.ArithSub, arg1, arg2=BICConstnt(value, _)}, context, _, destination, tailCode) = let val target = asTarget destination (* If the argument is a constant we can subtract the tag beforehand. Check for short - see comment above. *) val constVal = if isShort value then semitag(Word.toLargeIntX(toShort value)) else 0 val (arg1Code, aReg1) = codeToPRegRev(arg1, context, tailCode) in (BlockSimple(ArithmeticFunction{oper=SUB, resultReg=target, operand1=aReg1, operand2=IntegerConstant constVal, ccRef=newCCRef(), opSize=polyWordOpSize}) :: arg1Code, RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.WordArith BuiltIns.ArithSub, arg1, arg2}, context, _, destination, tailCode) = let val target = asTarget destination val aReg3 = newPReg() val (arg1Code, aReg1) = codeToPReg(arg1, context) val (arg2Code, aReg2) = codeToPReg(arg2, context) val code = arg1Code @ arg2Code @ (* Do the subtraction and add in the tag bit. This could be reordered if we have cascaded operations since we don't need to check for overflow. *) [BlockSimple(ArithmeticFunction{oper=SUB, resultReg=aReg3, operand1=aReg1, operand2=RegisterArgument aReg2, ccRef=newCCRef(), opSize=polyWordOpSize}), BlockSimple(ArithmeticFunction{oper=ADD, resultReg=target, operand1=aReg3, operand2=IntegerConstant 1, ccRef=newCCRef(), opSize=polyWordOpSize})] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.WordArith BuiltIns.ArithMult, arg1, arg2=BICConstnt(value, _)}, context, _, destination, tailCode) = codeMultiplyConstantWordRev(arg1, context, destination, if isShort value then toShort value else 0w0, tailCode) | codeToICodeBinaryRev({oper=BuiltIns.WordArith BuiltIns.ArithMult, arg1=BICConstnt(value, _), arg2}, context, _, destination, tailCode) = codeMultiplyConstantWordRev(arg2, context, destination, if isShort value then toShort value else 0w0, tailCode) | codeToICodeBinaryRev({oper=BuiltIns.WordArith BuiltIns.ArithMult, arg1, arg2}, context, _, destination, tailCode) = let val target = asTarget destination val (arg1Code, aReg1) = codeToPReg(arg1, context) val (arg2Code, aReg2) = codeToPReg(arg2, context) val arg1Untagged = newUReg() and arg2Untagged = newUReg() and resUntagged = newUReg() val code = arg1Code @ arg2Code @ (* Shift one argument and subtract the tag from the other. It's possible this could be reordered if we have a value that is already untagged. *) [BlockSimple(UntagValue{source=aReg1, dest=arg1Untagged, isSigned=false, cache=NONE, opSize=polyWordOpSize}), BlockSimple(ArithmeticFunction{oper=SUB, resultReg=arg2Untagged, operand1=aReg2, operand2=IntegerConstant 1, ccRef=newCCRef(), opSize=polyWordOpSize}), BlockSimple(Multiplication{resultReg=resUntagged, operand1=arg1Untagged, operand2=RegisterArgument arg2Untagged, ccRef=newCCRef(), opSize=polyWordOpSize}), BlockSimple(ArithmeticFunction{oper=ADD, resultReg=target, operand1=resUntagged, operand2=IntegerConstant 1, ccRef=newCCRef(), opSize=polyWordOpSize})] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.WordArith BuiltIns.ArithDiv, arg1, arg2}, context, _, destination, tailCode) = let val target = asTarget destination val (arg1Code, aReg1) = codeToPReg(arg1, context) val (arg2Code, aReg2) = codeToPReg(arg2, context) val arg1Untagged = newUReg() and arg2Untagged = newUReg() val quotient = newUReg() and remainder = newUReg() val code = arg1Code @ arg2Code @ (* Shift both of the arguments to remove the tags. We don't test for zero here - that's done explicitly. *) [BlockSimple(UntagValue{source=aReg1, dest=arg1Untagged, isSigned=false, cache=NONE, opSize=polyWordOpSize}), BlockSimple(UntagValue{source=aReg2, dest=arg2Untagged, isSigned=false, cache=NONE, opSize=polyWordOpSize}), BlockSimple(Division { isSigned = false, dividend=arg1Untagged, divisor=RegisterArgument arg2Untagged, quotient=quotient, remainder=remainder, opSize=polyWordOpSize }), BlockSimple(TagValue { source=quotient, dest=target, isSigned=false, opSize=polyWordOpSize })] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.WordArith BuiltIns.ArithMod, arg1, arg2}, context, _, destination, tailCode) = let (* Identical to Quot except that the result is the remainder. *) val target = asTarget destination val (arg1Code, aReg1) = codeToPReg(arg1, context) val (arg2Code, aReg2) = codeToPReg(arg2, context) val arg1Untagged = newUReg() and arg2Untagged = newUReg() val quotient = newUReg() and remainder = newUReg() val code = arg1Code @ arg2Code @ (* Shift both of the arguments to remove the tags. *) [BlockSimple(UntagValue{source=aReg1, dest=arg1Untagged, isSigned=false, cache=NONE, opSize=polyWordOpSize}), BlockSimple(UntagValue{source=aReg2, dest=arg2Untagged, isSigned=false, cache=NONE, opSize=polyWordOpSize}), BlockSimple(Division { isSigned = false, dividend=arg1Untagged, divisor=RegisterArgument arg2Untagged, quotient=quotient, remainder=remainder, opSize=polyWordOpSize }), BlockSimple(TagValue { source=remainder, dest=target, isSigned=false, opSize=polyWordOpSize })] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.WordArith _, ...}, _, _, _, _) = raise InternalError "codeToICodeNonRev: WordArith - unimplemented operation" | codeToICodeBinaryRev({oper=BuiltIns.WordLogical logOp, arg1, arg2=BICConstnt(value, _)}, context, _, destination, tailCode) = let val target = asTarget destination val (arg1Code, arg1Reg) = codeToPReg(arg1, context) (* Use a semitagged value for XOR. This preserves the tag bit. Use toLargeIntX here because the operations will sign-extend 32-bit values. *) val constVal = if isShort value then (case logOp of BuiltIns.LogicalXor => semitag | _ => tag) (Word.toLargeIntX(toShort value)) else 0 val oper = case logOp of BuiltIns.LogicalOr => OR | BuiltIns.LogicalAnd => AND | BuiltIns.LogicalXor => XOR (* If we AND with a value that fits in 32-bits we can use a 32-bit operation. *) val opSize = if logOp = BuiltIns.LogicalAnd andalso constVal <= 0xffffffff andalso constVal >= 0 then OpSize32 else polyWordOpSize val code = arg1Code @ [BlockSimple(ArithmeticFunction{oper=oper, resultReg=target, operand1=arg1Reg, operand2=IntegerConstant constVal, ccRef=newCCRef(), opSize=opSize})] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.WordLogical logOp, arg1=BICConstnt(value, _), arg2}, context, _, destination, tailCode) = let val target = asTarget destination val (arg2Code, arg2Reg) = codeToPReg(arg2, context) (* Use a semitagged value for XOR. This preserves the tag bit. *) val constVal = if isShort value then (case logOp of BuiltIns.LogicalXor => semitag | _ => tag) (Word.toLargeIntX(toShort value)) else 0 val oper = case logOp of BuiltIns.LogicalOr => OR | BuiltIns.LogicalAnd => AND | BuiltIns.LogicalXor => XOR (* If we AND with a value that fits in 32-bits we can use a 32-bit operation. *) val opSize = if logOp = BuiltIns.LogicalAnd andalso constVal <= 0xffffffff andalso constVal >= 0 then OpSize32 else polyWordOpSize val code = arg2Code @ [BlockSimple(ArithmeticFunction{oper=oper, resultReg=target, operand1=arg2Reg, operand2=IntegerConstant constVal, ccRef=newCCRef(), opSize=opSize})] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.WordLogical BuiltIns.LogicalOr, arg1, arg2}, context, _, destination, tailCode) = let val target = asTarget destination val (arg1Code, arg1Reg) = codeToPReg(arg1, context) val (arg2Code, arg2Reg) = codeToPReg(arg2, context) val code = arg1Code @ arg2Code @ (* Or-ing preserves the tag bit. *) [BlockSimple(ArithmeticFunction{oper=OR, resultReg=target, operand1=arg1Reg, operand2=RegisterArgument arg2Reg, ccRef=newCCRef(), opSize=polyWordOpSize})] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.WordLogical BuiltIns.LogicalAnd, arg1, arg2}, context, _, destination, tailCode) = let val target = asTarget destination val (arg1Code, arg1Reg) = codeToPReg(arg1, context) val (arg2Code, arg2Reg) = codeToPReg(arg2, context) val code = arg1Code @ arg2Code @ (* Since they're both tagged the result will be tagged. *) [BlockSimple(ArithmeticFunction{oper=AND, resultReg=target, operand1=arg1Reg, operand2=RegisterArgument arg2Reg, ccRef=newCCRef(), opSize=polyWordOpSize})] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.WordLogical BuiltIns.LogicalXor, arg1, arg2}, context, _, destination, tailCode) = let val target = asTarget destination val (arg1Code, arg1Reg) = codeToPReg(arg1, context) val (arg2Code, arg2Reg) = codeToPReg(arg2, context) val aReg3 = newPReg() val code = arg1Code @ arg2Code @ (* We need to restore the tag bit after the operation. *) [BlockSimple(ArithmeticFunction{oper=XOR, resultReg=aReg3, operand1=arg1Reg, operand2=RegisterArgument arg2Reg, ccRef=newCCRef(), opSize=polyWordOpSize}), BlockSimple(ArithmeticFunction{oper=OR, resultReg=target, operand1=aReg3, operand2=IntegerConstant 1, ccRef=newCCRef(), opSize=polyWordOpSize})] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.WordShift BuiltIns.ShiftLeft, arg1, arg2=BICConstnt(value, _)}, context, _, destination, tailCode) = (* Use the general case multiplication code. This will use a shift except for small values. It does detect special cases such as multiplication by 4 and 8 which can be implemented with LEA. *) codeMultiplyConstantWordRev(arg1, context, destination, if isShort value then Word.<<(0w1, toShort value) else 0w1, tailCode) | codeToICodeBinaryRev({oper=BuiltIns.WordShift shift, arg1, arg2}, context, _, destination, tailCode) = (* N.B. X86 shifts of greater than the word length mask the higher bits. That isn't what ML wants but that is dealt with at a higher level *) let open BuiltIns val target = asTarget destination (* Load the value into an untagged register. If this is a left shift we need to clear the tag bit. We don't need to do that for right shifts. *) val argRegUntagged = newUReg() val arg1Code = case arg1 of BICConstnt(value, _) => let (* Remove the tag bit. This isn't required for right shifts. *) val cnstntVal = if isShort value then semitag(Word.toLargeInt(toShort value)) else 1 in [BlockSimple(LoadArgument{source=IntegerConstant cnstntVal, dest=argRegUntagged, kind=movePolyWord})] end | _ => let val (arg1Code, arg1Reg) = codeToPReg(arg1, context) val removeTag = case shift of ShiftLeft => ArithmeticFunction{oper=SUB, resultReg=argRegUntagged, operand1=arg1Reg, operand2=IntegerConstant 1, ccRef=newCCRef(), opSize=polyWordOpSize} | _ => LoadArgument{source=RegisterArgument arg1Reg, dest=argRegUntagged, kind=movePolyWord} in arg1Code @ [BlockSimple removeTag] end (* The shift amount can usefully be a constant. *) val (arg2Code, untag2Code, arg2Arg) = codeAsUntaggedByte(arg2, false, context) val resRegUntagged = newUReg() val shiftOp = case shift of ShiftLeft => SHL | ShiftRightLogical => SHR | ShiftRightArithmetic => SAR val code = arg1Code @ arg2Code @ untag2Code @ [BlockSimple(ShiftOperation{ shift=shiftOp, resultReg=resRegUntagged, operand=argRegUntagged, shiftAmount=arg2Arg, ccRef=newCCRef(), opSize=polyWordOpSize }), (* Set the tag by ORing it in. This will work whether or not a right shift has shifted a 1 into this position. *) BlockSimple( ArithmeticFunction{oper=OR, resultReg=target, operand1=resRegUntagged, operand2=IntegerConstant 1, ccRef=newCCRef(), opSize=polyWordOpSize})] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.AllocateByteMemory, arg1, arg2}, context, _, destination, tailCode) = let val target = asTarget destination val sizeReg = newPReg() and baseReg = newPReg() val sizeCode = codeToICodeTarget(arg1, context, false, sizeReg) val (flagsCode, flagUntag, flagArg) = codeAsUntaggedByte(arg2, false, context) val code =sizeCode @ flagsCode @ [BlockSimple(AllocateMemoryVariable{size=sizeReg, dest=baseReg, saveRegs=[]})] @ flagUntag @ [BlockSimple(StoreArgument{ source=flagArg, base=baseReg, offset= ~1, index=memIndexOrObject, kind=MoveByte, isMutable=false}), BlockSimple InitialisationComplete, BlockSimple(LoadArgument{ source=RegisterArgument baseReg, dest=target, kind=movePolyWord})] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.LargeWordComparison test, arg1, arg2}, context, _, destination, tailCode) = let val ccRef = newCCRef() val (arg1Code, arg1Reg) = codeToPRegRev(arg1, context, tailCode) (* In X64 we can extract the word from a constant and do the comparison directly. That can't be done in X86/32 because the value isn't tagged and might look like an address. The RTS scans for comparisons with inline constant addresses. *) val (arg2Code, arg2Operand) = if targetArch <> Native32Bit then (* Native 64-bit or 32-in-64. *) ( case arg2 of BICConstnt(value, _) => (arg1Code, IntegerConstant(largeWordConstant value)) | _ => let val (code, reg) = codeToPRegRev(arg2, context, arg1Code) in (code, wordAt reg) end ) else let val (code, reg) = codeToPRegRev(arg2, context, arg1Code) in (code, wordAt reg) end val argReg = newUReg() val target = asTarget destination val code = makeBoolResultRev(testAsBranch(test, false, true), ccRef, target, BlockSimple(WordComparison{arg1=argReg, arg2=arg2Operand, ccRef=ccRef, opSize=nativeWordOpSize}) :: BlockSimple(LoadArgument{source=wordAt arg1Reg, dest=argReg, kind=moveNativeWord}) :: arg2Code) in (code, RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.LargeWordArith BuiltIns.ArithAdd, arg1, arg2=BICConstnt(value, _)}, context, _, destination, tailCode) = let val target = asTarget destination val (arg1Code, aReg1) = codeToPReg(arg1, context) val aReg3 = newUReg() val argReg = newUReg() val constantValue = largeWordConstant value val code =arg1Code @ [BlockSimple(LoadArgument{source=wordAt aReg1, dest=argReg, kind=moveNativeWord}), BlockSimple(ArithmeticFunction{oper=ADD, resultReg=aReg3, operand1=argReg, operand2=IntegerConstant constantValue, ccRef=newCCRef(), opSize=nativeWordOpSize}), BlockSimple(BoxValue{boxKind=BoxLargeWord, source=aReg3, dest=target, saveRegs=[]})] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.LargeWordArith BuiltIns.ArithAdd, arg1=BICConstnt(value, _), arg2}, context, _, destination, tailCode) = let val target = asTarget destination val (arg2Code, aReg2) = codeToPReg(arg2, context) val aReg3 = newUReg() val argReg = newUReg() val constantValue = largeWordConstant value val code = arg2Code @ [BlockSimple(LoadArgument{source=wordAt aReg2, dest=argReg, kind=moveNativeWord}), BlockSimple(ArithmeticFunction{oper=ADD, resultReg=aReg3, operand1=argReg, operand2=IntegerConstant constantValue, ccRef=newCCRef(), opSize=nativeWordOpSize}), BlockSimple(BoxValue{boxKind=BoxLargeWord, source=aReg3, dest=target, saveRegs=[]})] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.LargeWordArith BuiltIns.ArithAdd, arg1, arg2}, context, _, destination, tailCode) = let val target = asTarget destination val (arg1Code, aReg1) = codeToPReg(arg1, context) val (arg2Code, aReg2) = codeToPReg(arg2, context) val aReg3 = newUReg() val argReg = newUReg() val code = arg1Code @ arg2Code @ [BlockSimple(LoadArgument{source=wordAt aReg1, dest=argReg, kind=moveNativeWord}), BlockSimple(ArithmeticFunction{oper=ADD, resultReg=aReg3, operand1=argReg, operand2=wordAt aReg2, ccRef=newCCRef(), opSize=nativeWordOpSize}), BlockSimple(BoxValue{boxKind=BoxLargeWord, source=aReg3, dest=target, saveRegs=[]})] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.LargeWordArith BuiltIns.ArithSub, arg1, arg2=BICConstnt(value, _)}, context, _, destination, tailCode) = let val target = asTarget destination val (arg1Code, aReg1) = codeToPReg(arg1, context) val aReg3 = newUReg() val argReg = newUReg() val constantValue = largeWordConstant value val code = arg1Code @ [BlockSimple(LoadArgument{source=wordAt aReg1, dest=argReg, kind=moveNativeWord}), BlockSimple(ArithmeticFunction{oper=SUB, resultReg=aReg3, operand1=argReg, operand2=IntegerConstant constantValue, ccRef=newCCRef(), opSize=nativeWordOpSize}), BlockSimple(BoxValue{boxKind=BoxLargeWord, source=aReg3, dest=target, saveRegs=[]})] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.LargeWordArith BuiltIns.ArithSub, arg1, arg2}, context, _, destination, tailCode) = let val target = asTarget destination val (arg1Code, aReg1) = codeToPReg(arg1, context) val (arg2Code, aReg2) = codeToPReg(arg2, context) val aReg3 = newUReg() val argReg = newUReg() val code = arg1Code @ arg2Code @ [BlockSimple(LoadArgument{source=wordAt aReg1, dest=argReg, kind=moveNativeWord}), BlockSimple(ArithmeticFunction{oper=SUB, resultReg=aReg3, operand1=argReg, operand2=wordAt aReg2, ccRef=newCCRef(), opSize=nativeWordOpSize}), BlockSimple(BoxValue{boxKind=BoxLargeWord, source=aReg3, dest=target, saveRegs=[]})] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.LargeWordArith BuiltIns.ArithMult, arg1, arg2}, context, _, destination, tailCode) = let val target = asTarget destination val resValue = newUReg() val (arg1Code, aReg1) = codeToPReg(arg1, context) val (arg2Code, aReg2) = codeToPReg(arg2, context) val argReg1 = newUReg() val code = arg1Code @ arg2Code @ [BlockSimple(LoadArgument{source=wordAt aReg1, dest=argReg1, kind=moveNativeWord}), BlockSimple(Multiplication{resultReg=resValue, operand1=argReg1, operand2=wordAt aReg2, ccRef=newCCRef(), opSize=nativeWordOpSize}), BlockSimple(BoxValue{boxKind=BoxLargeWord, source=resValue, dest=target, saveRegs=[]})] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.LargeWordArith BuiltIns.ArithDiv, arg1, arg2}, context, _, destination, tailCode) = let val target = asTarget destination val (arg1Code, aReg1) = codeToPReg(arg1, context) val (arg2Code, aReg2) = codeToPReg(arg2, context) val quotient = newUReg() and remainder = newUReg() val dividendReg = newUReg() and divisorReg = newUReg() val code = arg1Code @ arg2Code @ (* We don't test for zero here - that's done explicitly. *) [BlockSimple(LoadArgument{source=wordAt aReg1, dest=dividendReg, kind=moveNativeWord}), BlockSimple(LoadArgument{source=wordAt aReg2, dest=divisorReg, kind=moveNativeWord}), BlockSimple(Division { isSigned = false, dividend=dividendReg, divisor=RegisterArgument divisorReg, quotient=quotient, remainder=remainder, opSize=nativeWordOpSize }), BlockSimple(BoxValue{boxKind=BoxLargeWord, source=quotient, dest=target, saveRegs=[]})] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.LargeWordArith BuiltIns.ArithMod, arg1, arg2}, context, _, destination, tailCode) = let val target = asTarget destination val (arg1Code, aReg1) = codeToPReg(arg1, context) val (arg2Code, aReg2) = codeToPReg(arg2, context) val quotient = newUReg() and remainder = newUReg() val dividendReg = newUReg() and divisorReg = newUReg() val code = arg1Code @ arg2Code @ (* We don't test for zero here - that's done explicitly. *) [BlockSimple(LoadArgument{source=wordAt aReg1, dest=dividendReg, kind=moveNativeWord}), BlockSimple(LoadArgument{source=wordAt aReg2, dest=divisorReg, kind=moveNativeWord}), BlockSimple(Division { isSigned = false, dividend=dividendReg, divisor=RegisterArgument divisorReg, quotient=quotient, remainder=remainder, opSize=nativeWordOpSize }), BlockSimple(BoxValue{boxKind=BoxLargeWord, source=remainder, dest=target, saveRegs=[]})] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.LargeWordArith _, ...}, _, _, _, _) = raise InternalError "codeToICodeNonRev: LargeWordArith - unimplemented operation" | codeToICodeBinaryRev({oper=BuiltIns.LargeWordLogical logOp, arg1, arg2=BICConstnt(value, _)}, context, _, destination, tailCode) = let val target = asTarget destination val (arg1Code, aReg1) = codeToPReg(arg1, context) val aReg3 = newUReg() val argReg = newUReg() val constantValue = largeWordConstant value val oper = case logOp of BuiltIns.LogicalOr => OR | BuiltIns.LogicalAnd => AND | BuiltIns.LogicalXor => XOR (* If we AND with a value that fits in 32-bits we can use a 32-bit operation. *) val opSize = if logOp = BuiltIns.LogicalAnd andalso constantValue <= 0xffffffff andalso constantValue >= 0 then OpSize32 else nativeWordOpSize val code = arg1Code @ [BlockSimple(LoadArgument{source=wordAt aReg1, dest=argReg, kind=moveNativeWord}), BlockSimple(ArithmeticFunction{oper=oper, resultReg=aReg3, operand1=argReg, operand2=IntegerConstant constantValue, ccRef=newCCRef(), opSize=opSize}), BlockSimple(BoxValue{boxKind=BoxLargeWord, source=aReg3, dest=target, saveRegs=[]})] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.LargeWordLogical logOp, arg1=BICConstnt(value, _), arg2}, context, _, destination, tailCode) = let val target = asTarget destination val (arg2Code, aReg2) = codeToPReg(arg2, context) val aReg3 = newUReg() val argReg = newUReg() val constantValue = largeWordConstant value val oper = case logOp of BuiltIns.LogicalOr => OR | BuiltIns.LogicalAnd => AND | BuiltIns.LogicalXor => XOR (* If we AND with a value that fits in 32-bits we can use a 32-bit operation. *) val opSize = if logOp = BuiltIns.LogicalAnd andalso constantValue <= 0xffffffff andalso constantValue >= 0 then OpSize32 else nativeWordOpSize val code = arg2Code @ [BlockSimple(LoadArgument{source=wordAt aReg2, dest=argReg, kind=moveNativeWord}), BlockSimple(ArithmeticFunction{oper=oper, resultReg=aReg3, operand1=argReg, operand2=IntegerConstant constantValue, ccRef=newCCRef(), opSize=opSize}), BlockSimple(BoxValue{boxKind=BoxLargeWord, source=aReg3, dest=target, saveRegs=[]})] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.LargeWordLogical logOp, arg1, arg2}, context, _, destination, tailCode) = let val target = asTarget destination val (arg1Code, aReg1) = codeToPReg(arg1, context) val (arg2Code, aReg2) = codeToPReg(arg2, context) val aReg3 = newUReg() val argReg = newUReg() val oper = case logOp of BuiltIns.LogicalOr => OR | BuiltIns.LogicalAnd => AND | BuiltIns.LogicalXor => XOR val code = arg1Code @ arg2Code @ [BlockSimple(LoadArgument{source=wordAt aReg1, dest=argReg, kind=moveNativeWord}), BlockSimple(ArithmeticFunction{oper=oper, resultReg=aReg3, operand1=argReg, operand2=wordAt aReg2, ccRef=newCCRef(), opSize=nativeWordOpSize}), BlockSimple(BoxValue{boxKind=BoxLargeWord, source=aReg3, dest=target, saveRegs=[]})] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.LargeWordShift shift, arg1, arg2}, context, _, destination, tailCode) = (* The shift is always a Word.word value i.e. tagged. There is a check at the higher level that the shift does not exceed 32/64 bits. *) let open BuiltIns val target = asTarget destination val (arg1Code, aReg1) = codeToPReg(arg1, context) val (arg2Code, untag2Code, arg2Arg) = codeAsUntaggedByte(arg2, false, context) val aReg3 = newUReg() val shiftOp = case shift of ShiftLeft => SHL | ShiftRightLogical => SHR | ShiftRightArithmetic => SAR val argReg = newUReg() val code = arg1Code @ arg2Code @ [BlockSimple(LoadArgument{source=wordAt aReg1, dest=argReg, kind=moveNativeWord})] @ untag2Code @ [BlockSimple(ShiftOperation{ shift=shiftOp, resultReg=aReg3, operand=argReg, shiftAmount=arg2Arg, ccRef=newCCRef(), opSize=nativeWordOpSize }), BlockSimple(BoxValue{boxKind=BoxLargeWord, source=aReg3, dest=target, saveRegs=[]})] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.RealArith(fpOpPrec as (fpOp, fpPrec)), arg1, arg2}, context, _, destination, tailCode) = let open BuiltIns val commutative = case fpOp of ArithSub => NonCommutative | ArithDiv => NonCommutative | ArithAdd => Commutative | ArithMult => Commutative | _ => raise InternalError "codeToICodeNonRev: RealArith - unimplemented operation" val (argCodeRev, fpRegSrc, arg2Value) = codeFPBinaryArgsRev(arg1, arg2, fpPrec, commutative, context, []) val argCode = List.rev argCodeRev val target = asTarget destination val fpRegDest = newUReg() val arith = case fpMode of FPModeX87 => let val fpOp = case fpOp of ArithAdd => FADD | ArithSub => FSUB | ArithMult => FMUL | ArithDiv => FDIV | _ => raise InternalError "codeToICodeNonRev: RealArith - unimplemented operation" val isDouble = case fpPrec of PrecSingle => false | PrecDouble => true in [BlockSimple(X87FPArith{ opc=fpOp, resultReg=fpRegDest, arg1=fpRegSrc, arg2=arg2Value, isDouble=isDouble})] end | FPModeSSE2 => let val fpOp = case fpOpPrec of (ArithAdd, PrecSingle) => SSE2BAddSingle | (ArithSub, PrecSingle) => SSE2BSubSingle | (ArithMult, PrecSingle) => SSE2BMulSingle | (ArithDiv, PrecSingle) => SSE2BDivSingle | (ArithAdd, PrecDouble) => SSE2BAddDouble | (ArithSub, PrecDouble) => SSE2BSubDouble | (ArithMult, PrecDouble) => SSE2BMulDouble | (ArithDiv, PrecDouble) => SSE2BDivDouble | _ => raise InternalError "codeToICodeNonRev: RealArith - unimplemented operation" in [BlockSimple(SSE2FPBinary{ opc=fpOp, resultReg=fpRegDest, arg1=fpRegSrc, arg2=arg2Value})] end (* Box or tag the result. *) val result = boxOrTagReal(fpRegDest, target, fpPrec) in (revApp(argCode @ arith @ result, tailCode), RegisterArgument target, false) end (* Floating point comparison. This is complicated because we have different instruction sequences for SSE2 and X87. We also have to get the handling of unordered (NaN) values right. All the tests are treated as false if either argument is a NaN. To combine that test with the other tests we sometimes have to reverse the comparison. *) | codeToICodeBinaryRev({oper=BuiltIns.RealComparison(BuiltIns.TestEqual, precision), arg1, arg2}, context, _, destination, tailCode) = let (* Get the arguments. It's commutative. *) val (arg2Code, fpReg, arg2Val) = codeFPBinaryArgsRev(arg1, arg2, precision, Commutative, context, tailCode) val ccRef1 = newCCRef() and ccRef2 = newCCRef() val testReg1 = newUReg() and testReg2 = newUReg() and testReg3 = newUReg() (* If this is X87 we get the condition into RAX and test it there. If it is SSE2 we have to treat the unordered result (parity set) specially. *) val isDouble = precision = BuiltIns.PrecDouble val target = asTarget destination val code = case fpMode of FPModeX87 => makeBoolResultRev(JE, ccRef2, target, BlockSimple(ArithmeticFunction{ oper=XOR, resultReg=testReg3, operand1=testReg2, operand2=IntegerConstant 0x4000, ccRef=ccRef2, opSize=OpSize32 }) :: BlockSimple(ArithmeticFunction{ oper=AND, resultReg=testReg2, operand1=testReg1, operand2=IntegerConstant 0x4400, ccRef=newCCRef(), opSize=OpSize32 }) :: BlockSimple(X87FPGetCondition { ccRef=ccRef1, dest=testReg1 }) :: BlockSimple(X87Compare{arg1=fpReg, arg2=arg2Val, ccRef=ccRef1, isDouble = isDouble}) :: arg2Code) | FPModeSSE2 => let val noParityLabel = newLabel() val resultLabel = newLabel() val falseLabel = newLabel() val trueLabel = newLabel() val mergeReg = newMergeReg() in BlockSimple(LoadArgument{ source=RegisterArgument mergeReg, dest=target, kind=Move32Bit }) :: BlockLabel resultLabel :: BlockFlow(Unconditional resultLabel) :: (* Result is false if parity is set i.e. unordered or if unequal. *) BlockSimple(LoadArgument{ source=IntegerConstant(tag 0), dest=mergeReg, kind=Move32Bit }) :: BlockLabel falseLabel :: BlockFlow(Unconditional resultLabel) :: (* Result is true if it's ordered and equal. *) BlockSimple(LoadArgument{ source=IntegerConstant(tag 1), dest=mergeReg, kind=Move32Bit }) :: BlockLabel trueLabel :: (* Not unordered - test the equality *) BlockFlow(Conditional{ccRef=ccRef1, condition=JE, trueJump=trueLabel, falseJump=falseLabel}) :: BlockLabel noParityLabel :: (* Go to falseLabel if unordered and therefore not equal. *) BlockFlow(Conditional{ccRef=ccRef1, condition=JP, trueJump=falseLabel, falseJump=noParityLabel}) :: BlockSimple(SSE2Compare{arg1=fpReg, arg2=arg2Val, ccRef=ccRef1, isDouble = isDouble}) :: arg2Code end in (code, RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.RealComparison(BuiltIns.TestUnordered, precision), arg1, arg2}, context, _, destination, tailCode) = let (* The unordered test is really included because it is easy to implement and is the simplest way of implementing isNan. *) (* Get the arguments. It's commutative. *) val (arg2Code, fpReg, arg2Val) = codeFPBinaryArgsRev(arg1, arg2, precision, Commutative, context, tailCode) val ccRef1 = newCCRef() and ccRef2 = newCCRef() val testReg1 = newUReg() and testReg2 = newUReg() and testReg3 = newUReg() (* If this is X87 we get the condition into RAX and test it there. If it is SSE2 we have to treat the unordered result (parity set) specially. *) val isDouble = precision = BuiltIns.PrecDouble val target = asTarget destination val code = case fpMode of FPModeX87 => (* And with 0x4500. We have to use XOR rather than CMP to avoid having an untagged constant comparison. *) makeBoolResultRev(JE, ccRef2, target, BlockSimple(ArithmeticFunction{ oper=XOR, resultReg=testReg3, operand1=testReg2, operand2=IntegerConstant 0x4500, ccRef=ccRef2, opSize=OpSize32 }) :: BlockSimple(ArithmeticFunction{ oper=AND, resultReg=testReg2, operand1=testReg1, operand2=IntegerConstant 0x4500, ccRef=newCCRef(), opSize=OpSize32 }) :: BlockSimple(X87FPGetCondition { ccRef=ccRef1, dest=testReg1 }) :: BlockSimple(X87Compare{arg1=fpReg, arg2=arg2Val, ccRef=ccRef1, isDouble = isDouble}) :: arg2Code) | FPModeSSE2 => makeBoolResultRev(JP, ccRef1, target, BlockSimple(SSE2Compare{arg1=fpReg, arg2=arg2Val, ccRef=ccRef1, isDouble = isDouble}) :: arg2Code) in (code, RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.RealComparison(comparison, precision), arg1, arg2}, context, _, destination, tailCode) = let (* Ordered comparisons are complicated because they are all defined to be false if either argument is a NaN. We have two different tests for a > b and a >= b and implement a < b and a <= b by changing the order of the arguments. *) val (arg1Code, arg1Value) = codeFPArgument(arg1, precision, context, tailCode) val (arg2Code, arg2Value) = codeFPArgument(arg2, precision, context, arg1Code) val (regArg, opArg, isGeq) = case comparison of BuiltIns.TestGreater => (arg1Value, arg2Value, false) | BuiltIns.TestLess => (arg2Value, arg1Value, false) (* Reversed: aa. *) | BuiltIns.TestGreaterEqual => (arg1Value, arg2Value, true) | BuiltIns.TestLessEqual => (arg2Value, arg1Value, true) (* Reversed: a<=b is b>=a. *) | _ => raise InternalError "RealComparison: unimplemented operation" (* Load the first operand into a register. *) val (fpReg, loadCode) = case regArg of RegisterArgument fpReg => (fpReg, arg2Code) | regArg => let val fpReg = newUReg() val moveOp = case precision of BuiltIns.PrecDouble => MoveDouble | BuiltIns.PrecSingle => MoveFloat in (fpReg, BlockSimple(LoadArgument{source=regArg, dest=fpReg, kind=moveOp}) :: arg2Code) end val isDouble = precision = BuiltIns.PrecDouble val target = asTarget destination val code = case fpMode of FPModeX87 => let val testReg1 = newUReg() and testReg2 = newUReg() val ccRef1 = newCCRef() and ccRef2 = newCCRef() val testBits = if isGeq then 0x500 else 0x4500 in makeBoolResultRev(JE, ccRef2, target, BlockSimple(ArithmeticFunction{ oper=AND, resultReg=testReg2, operand1=testReg1, operand2=IntegerConstant testBits, ccRef=ccRef2, opSize=OpSize32 }) :: BlockSimple(X87FPGetCondition { ccRef=ccRef1, dest=testReg1 }) :: BlockSimple(X87Compare{arg1=fpReg, arg2=opArg, ccRef=ccRef1, isDouble = isDouble}) :: loadCode) end | FPModeSSE2 => let val ccRef1 = newCCRef() val condition = if isGeq then JNB (* >=, <= *) else JA (* >, < *) in makeBoolResultRev(condition, ccRef1, target, BlockSimple(SSE2Compare{arg1=fpReg, arg2=opArg, ccRef=ccRef1, isDouble = isDouble}) :: loadCode) end in (code, RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.FreeCStack, arg1, arg2}, context, _, destination, tailCode) = (* Free space on the C stack by storing the address in the argument into the "memory register". This is a binary operation that takes the base address and the size. The base address isn't used in this version. *) let val (arg2Code, untaggedLength) = case arg2 of BICConstnt(value, _) => (tailCode, IntegerConstant(Word.toLargeInt(toShort value)) (* Leave untagged *)) | _ => let val (arg2Code, lengthReg) = codeToPRegRev(arg2, context, tailCode) val lengthUntagged = newUReg() in ( BlockSimple(UntagValue{source=lengthReg, dest=lengthUntagged, isSigned=false, cache=NONE, opSize=polyWordOpSize}) :: arg2Code, RegisterArgument lengthUntagged ) end (* Evaluate the first argument for side-effects but discard it. *) val (arg1Code, _, _) = codeToICodeRev(arg1, context, false, Allowed allowDefer, arg2Code) val addrReg = newUReg() and resAddrReg = newUReg() val code = BlockSimple(StoreMemReg{offset=memRegCStackPtr, source=resAddrReg, kind=moveNativeWord}) :: BlockSimple(ArithmeticFunction{oper=ADD, resultReg=resAddrReg, operand1=addrReg, operand2=untaggedLength, ccRef=newCCRef(), opSize=nativeWordOpSize}) :: BlockSimple(LoadMemReg{offset=memRegCStackPtr, dest=addrReg, kind=moveNativeWord}) :: arg1Code in moveIfNotAllowedRev(destination, code, (* Unit result *) IntegerConstant(tag 0)) end (* Multiply tagged word by a constant. We're not concerned with overflow so it's possible to use various short cuts. *) and codeMultiplyConstantWordRev(arg, context, destination, multiplier, tailCode) = let val target = asTarget destination val (argCode, aReg) = codeToPReg(arg, context) val doMultiply = case multiplier of 0w0 => [BlockSimple(LoadArgument{source=IntegerConstant 1, dest=target, kind=movePolyWord})] | 0w1 => [BlockSimple(LoadArgument{source=RegisterArgument aReg, dest=target, kind=movePolyWord})] | 0w2 => [BlockSimple(LoadEffectiveAddress{base=SOME aReg, offset= ~1, index=MemIndex1 aReg, dest=target, opSize=polyWordOpSize})] | 0w3 => [BlockSimple(LoadEffectiveAddress{base=SOME aReg, offset= ~2, index=MemIndex2 aReg, dest=target, opSize=polyWordOpSize})] | 0w4 => [BlockSimple(LoadEffectiveAddress{base=NONE, offset= ~3, index=MemIndex4 aReg, dest=target, opSize=polyWordOpSize})] | 0w5 => [BlockSimple(LoadEffectiveAddress{base=SOME aReg, offset= ~4, index=MemIndex4 aReg, dest=target, opSize=polyWordOpSize})] | 0w8 => [BlockSimple(LoadEffectiveAddress{base=NONE, offset= ~7, index=MemIndex8 aReg, dest=target, opSize=polyWordOpSize})] | 0w9 => [BlockSimple(LoadEffectiveAddress{base=SOME aReg, offset= ~8, index=MemIndex8 aReg, dest=target, opSize=polyWordOpSize})] | _ => let val tReg = newUReg() val tagCorrection = Word.toLargeInt multiplier - 1 fun getPower2 n = let fun p2 (n, l) = if n = 0w1 then SOME l else if Word.andb(n, 0w1) = 0w1 then NONE else p2(Word.>>(n, 0w1), l+0w1) in if n = 0w0 then NONE else p2(n,0w0) end val multiply = case getPower2 multiplier of SOME power => (* Shift it including the tag. *) BlockSimple(ShiftOperation{ shift=SHL, resultReg=tReg, operand=aReg, shiftAmount=IntegerConstant(Word.toLargeInt power), ccRef=newCCRef(), opSize=polyWordOpSize }) | NONE => (* Multiply including the tag. *) BlockSimple(Multiplication{resultReg=tReg, operand1=aReg, operand2=IntegerConstant(Word.toLargeInt multiplier), ccRef=newCCRef(), opSize=polyWordOpSize}) in [multiply, BlockSimple(ArithmeticFunction{oper=SUB, resultReg=target, operand1=tReg, operand2=IntegerConstant tagCorrection, ccRef=newCCRef(), opSize=polyWordOpSize})] end in (revApp(argCode @ doMultiply, tailCode), RegisterArgument target, false) end and codeToICodeAllocate({numWords as BICConstnt(length, _), flags as BICConstnt(flagValue, _), initial}, context, _, destination) = (* Constant length and flags is used for ref. We could handle other cases. *) if isShort length andalso isShort flagValue andalso toShort length = 0w1 then let val target = asTarget destination (* Force a different register. *) val vecLength = Word.toInt(toShort length) val flagByte = Word8.fromLargeWord(Word.toLargeWord(toShort flagValue)) val memAddr = newPReg() and valueReg = newPReg() fun initialise n = BlockSimple(StoreArgument{ source=RegisterArgument valueReg, offset=n*Word.toInt wordSize, base=memAddr, index=memIndexOrObject, kind=movePolyWord, isMutable=false}) val code = codeToICodeTarget(initial, context, false, valueReg) @ [BlockSimple(AllocateMemoryOperation{size=vecLength, flags=flagByte, dest=memAddr, saveRegs=[]})] @ List.tabulate(vecLength, initialise) @ [BlockSimple InitialisationComplete, BlockSimple(LoadArgument{source=RegisterArgument memAddr, dest=target, kind=movePolyWord})] in (code, RegisterArgument target, false) end else (* If it's longer use the full run-time form. *) allocateMemoryVariable(numWords, flags, initial, context, destination) | codeToICodeAllocate({numWords, flags, initial}, context, _, destination) = allocateMemoryVariable(numWords, flags, initial, context, destination) and codeToICodeLoad({kind=LoadStoreMLWord _, address}, context, _, destination) = let val target = asTarget destination val (codeBaseIndex, codeUntag, memLoc) = codeAddress(address, false, context) in (codeBaseIndex @ codeUntag @ [BlockSimple(LoadArgument {source=MemoryLocation memLoc, dest=target, kind=movePolyWord})], RegisterArgument target, false) end | codeToICodeLoad({kind=LoadStoreMLByte _, address}, context, _, destination) = let val target = asTarget destination val (codeBaseIndex, codeUntag, memLoc) = codeAddress(address, true, context) val untaggedResReg = newUReg() in (codeBaseIndex @ codeUntag @ [BlockSimple(LoadArgument { source=MemoryLocation memLoc, dest=untaggedResReg, kind=MoveByte}), BlockSimple(TagValue {source=untaggedResReg, dest=target, isSigned=false, opSize=OpSize32})], RegisterArgument target, false) end | codeToICodeLoad({kind=LoadStoreC8, address}, context, _, destination) = let (* Load a byte from C memory. This is almost exactly the same as LoadStoreMLByte except that the base address is a LargeWord.word value. *) val target = asTarget destination val (codeBaseIndex, codeUntag, memLoc) = codeCAddress(address, 0w1, context) val untaggedResReg = newUReg() in (codeBaseIndex @ codeUntag @ [BlockSimple(LoadArgument { source=MemoryLocation memLoc, dest=untaggedResReg, kind=MoveByte}), BlockSimple(TagValue {source=untaggedResReg, dest=target, isSigned=false, opSize=OpSize32})], RegisterArgument target, false) end | codeToICodeLoad({kind=LoadStoreC16, address}, context, _, destination) = let (* Load a 16-bit value from C memory. *) val target = asTarget destination val (codeBaseIndex, codeUntag, memLoc) = codeCAddress(address, 0w2, context) val untaggedResReg = newUReg() in (codeBaseIndex @ codeUntag @ [BlockSimple(LoadArgument { source=MemoryLocation memLoc, dest=untaggedResReg, kind=Move16Bit}), BlockSimple(TagValue {source=untaggedResReg, dest=target, isSigned=false, opSize=OpSize32})], RegisterArgument target, false) end | codeToICodeLoad({kind=LoadStoreC32, address}, context, _, destination) = let (* Load a 32-bit value from C memory. If this is 64-bit mode we can tag it but if this is 32-bit mode we need to box it. *) val target = asTarget destination val (codeBaseIndex, codeUntag, memLoc) = codeCAddress(address, 0w4, context) val untaggedResReg = newUReg() val boxTagCode = if targetArch = Native64Bit then BlockSimple(TagValue {source=untaggedResReg, dest=target, isSigned=false, opSize=OpSize64 (* It becomes 33 bits *)}) else BlockSimple(BoxValue{boxKind=BoxLargeWord, source=untaggedResReg, dest=target, saveRegs=[]}) in (codeBaseIndex @ codeUntag @ [BlockSimple(LoadArgument { source=MemoryLocation memLoc, dest=untaggedResReg, kind=Move32Bit}), boxTagCode], RegisterArgument target, false) end | codeToICodeLoad({kind=LoadStoreC64, address}, context, _, destination) = let (* Load a 64-bit value from C memory. This is only allowed in 64-bit mode. The result is a boxed value. *) val _ = targetArch <> Native32Bit orelse raise InternalError "codeToICodeNonRev: BICLoadOperation LoadStoreC64 in 32-bit" val target = asTarget destination val (codeBaseIndex, codeUntag, memLoc) = codeCAddress(address, 0w8, context) val untaggedResReg = newUReg() in (codeBaseIndex @ codeUntag @ [BlockSimple(LoadArgument { source=MemoryLocation memLoc, dest=untaggedResReg, kind=Move64Bit}), BlockSimple(BoxValue{boxKind=BoxLargeWord, source=untaggedResReg, dest=target, saveRegs=[]})], RegisterArgument target, false) end | codeToICodeLoad({kind=LoadStoreCFloat, address}, context, _, destination) = let val target = asTarget destination val (codeBaseIndex, codeUntag, memLoc) = codeCAddress(address, 0w4, context) val untaggedResReg = newUReg() val boxFloat = case fpMode of FPModeX87 => BoxX87Double | FPModeSSE2 => BoxSSE2Double (* We need to convert the float into a double. *) val loadArg = case fpMode of FPModeX87 => BlockSimple(LoadArgument { source=MemoryLocation memLoc, dest=untaggedResReg, kind=MoveFloat}) | FPModeSSE2 => BlockSimple(SSE2FPUnary { source=MemoryLocation memLoc, resultReg=untaggedResReg, opc=SSE2UFloatToDouble}) in (codeBaseIndex @ codeUntag @ [loadArg, BlockSimple(BoxValue{boxKind=boxFloat, source=untaggedResReg, dest=target, saveRegs=[]})], RegisterArgument target, false) end | codeToICodeLoad({kind=LoadStoreCDouble, address}, context, _, destination) = let val target = asTarget destination val (codeBaseIndex, codeUntag, memLoc) = codeCAddress(address, 0w8, context) val untaggedResReg = newUReg() val boxFloat = case fpMode of FPModeX87 => BoxX87Double | FPModeSSE2 => BoxSSE2Double in (codeBaseIndex @ codeUntag @ [BlockSimple(LoadArgument { source=MemoryLocation memLoc, dest=untaggedResReg, kind=MoveDouble}), BlockSimple(BoxValue{boxKind=boxFloat, source=untaggedResReg, dest=target, saveRegs=[]})], RegisterArgument target, false) end | codeToICodeLoad({kind=LoadStoreUntaggedUnsigned, address}, context, _, destination) = let val target = asTarget destination val (codeBaseIndex, codeUntag, memLoc) = codeAddress(address, false, context) val untaggedResReg = newUReg() in (codeBaseIndex @ codeUntag @ [BlockSimple(LoadArgument { source=MemoryLocation memLoc, dest=untaggedResReg, kind=movePolyWord}), BlockSimple(TagValue {source=untaggedResReg, dest=target, isSigned=false, opSize=polyWordOpSize})], RegisterArgument target, false) end and codeToICodeStore({kind=LoadStoreMLWord _, address, value}, context, _, destination) = let val (sourceCode, source, _) = codeToICode(value, context, false, Allowed allowInMemMove) val (codeBaseIndex, codeUntag, {base, offset, index, ...}) = codeAddress(address, false, context) val code = codeBaseIndex @ sourceCode @ codeUntag @ [BlockSimple(StoreArgument {source=source, base=base, offset=offset, index=index, kind=movePolyWord, isMutable=true})] in moveIfNotAllowed(destination, code, (* Unit result *) IntegerConstant(tag 0)) end | codeToICodeStore({kind=LoadStoreMLByte _, address, value}, context, _, destination) = let val (codeBaseIndex, codeUntag, {base, offset, index, ...}) = codeAddress(address, true, context) (* We have to untag the value to store. *) val (valueCode, untagValue, valueArg) = codeAsUntaggedByte(value, false, context) val code = codeBaseIndex @ valueCode @ untagValue @ codeUntag @ [BlockSimple(StoreArgument {source=valueArg, base=base, offset=offset, index=index, kind=MoveByte, isMutable=true})] in moveIfNotAllowed(destination, code, (* Unit result *) IntegerConstant(tag 0)) end | codeToICodeStore({kind=LoadStoreC8, address, value}, context, _, destination) = let (* Store a byte to C memory. Almost exactly the same as LoadStoreMLByte. *) val (codeBaseIndex, codeUntag, {base, offset, index, ...}) = codeCAddress(address, 0w1, context) val (valueCode, untagValue, valueArg) = codeAsUntaggedByte(value, false, context) val code = codeBaseIndex @ valueCode @ untagValue @ codeUntag @ [BlockSimple(StoreArgument {source=valueArg, base=base, offset=offset, index=index, kind=MoveByte, isMutable=true})] in moveIfNotAllowed(destination, code, (* Unit result *) IntegerConstant(tag 0)) end | codeToICodeStore({kind=LoadStoreC16, address, value}, context, _, destination) = let (* Store a 16-bit value to C memory. *) val (codeBaseIndex, codeUntag, {base, offset, index, ...}) = codeCAddress(address, 0w2, context) (* We don't currently implement 16-bit constant moves so this must always be in a reg. *) val (valueCode, untagValue, valueArg) = codeAsUntaggedToReg(value, false, context) val code = codeBaseIndex @ valueCode @ untagValue @ codeUntag @ [BlockSimple(StoreArgument {source=RegisterArgument valueArg, base=base, offset=offset, index=index, kind=Move16Bit, isMutable=true})] in moveIfNotAllowed(destination, code, (* Unit result *) IntegerConstant(tag 0)) end | codeToICodeStore({kind=LoadStoreC32, address, value}, context, _, destination) = (* Store a 32-bit value. If this is 64-bit mode we untag it but if this is 32-bit mode we unbox it. *) let val (codeBaseIndex, codeUntag, {base, offset, index, ...}) = codeCAddress(address, 0w4, context) val code = if targetArch = Native64Bit then let (* We don't currently implement 32-bit constant moves so this must always be in a reg. *) val (valueCode, untagValue, valueArg) = codeAsUntaggedToReg(value, false, context) in codeBaseIndex @ valueCode @ untagValue @ codeUntag @ [BlockSimple(StoreArgument {source=RegisterArgument valueArg, base=base, offset=offset, index=index, kind=Move32Bit, isMutable=true})] end else let val (valueCode, valueReg) = codeToPReg(value, context) val valueReg1 = newUReg() in codeBaseIndex @ valueCode @ BlockSimple(LoadArgument{source=wordAt valueReg, dest=valueReg1, kind=Move32Bit}) :: codeUntag @ [BlockSimple(StoreArgument {source=RegisterArgument valueReg1, base=base, offset=offset, index=index, kind=Move32Bit, isMutable=true})] end in moveIfNotAllowed(destination, code, (* Unit result *) IntegerConstant(tag 0)) end | codeToICodeStore({kind=LoadStoreC64, address, value}, context, _, destination) = let (* Store a 64-bit value. *) val _ = targetArch <> Native32Bit orelse raise InternalError "codeToICodeNonRev: BICStoreOperation LoadStoreC64 in 32-bit" val (valueCode, valueReg) = codeToPReg(value, context) val valueReg1 = newUReg() val (codeBaseIndex, codeUntag, {base, offset, index, ...}) = codeCAddress(address, 0w8, context) val code = codeBaseIndex @ valueCode @ codeUntag @ [BlockSimple(LoadArgument{source=wordAt valueReg, dest=valueReg1, kind=Move64Bit}), BlockSimple(StoreArgument {source=RegisterArgument valueReg1, base=base, offset=offset, index=index, kind=Move64Bit, isMutable=true})] in moveIfNotAllowed(destination, code, (* Unit result *) IntegerConstant(tag 0)) end | codeToICodeStore({kind=LoadStoreCFloat, address, value}, context, _, destination) = let val floatReg = newUReg() and float2Reg = newUReg() val (codeBaseIndex, codeUntag, {base, offset, index, ...}) = codeCAddress(address, 0w4, context) val (valueCode, valueReg) = codeToPReg(value, context) (* If we're using an SSE2 reg we have to convert it from double to single precision. *) val (storeReg, cvtCode) = case fpMode of FPModeSSE2 => (float2Reg, [BlockSimple(SSE2FPUnary{opc=SSE2UDoubleToFloat, resultReg=float2Reg, source=RegisterArgument floatReg})]) | FPModeX87 => (floatReg, []) val code = codeBaseIndex @ valueCode @ codeUntag @ BlockSimple(LoadArgument{source=wordAt valueReg, dest=floatReg, kind=MoveDouble}) :: cvtCode @ [BlockSimple(StoreArgument {source=RegisterArgument storeReg, base=base, offset=offset, index=index, kind=MoveFloat, isMutable=true})] in moveIfNotAllowed(destination, code, (* Unit result *) IntegerConstant(tag 0)) end | codeToICodeStore({kind=LoadStoreCDouble, address, value}, context, _, destination) = let val floatReg = newUReg() val (codeBaseIndex, codeUntag, {base, offset, index, ...}) = codeCAddress(address, 0w8, context) val (valueCode, valueReg) = codeToPReg(value, context) val code = codeBaseIndex @ valueCode @ codeUntag @ [BlockSimple(LoadArgument{source=wordAt valueReg, dest=floatReg, kind=MoveDouble}), BlockSimple(StoreArgument {source=RegisterArgument floatReg, base=base, offset=offset, index=index, kind=MoveDouble, isMutable=true})] in moveIfNotAllowed(destination, code, (* Unit result *) IntegerConstant(tag 0)) end | codeToICodeStore({kind=LoadStoreUntaggedUnsigned, address, value}, context, _, destination) = let (* We have to untag the value to store. *) val (codeBaseIndex, codeUntag, {base, offset, index, ...}) = codeAddress(address, false, context) (* See if it's a constant. This is frequently used to set the last word of a string to zero. *) (* We have to be a bit more careful on the X86. We use moves to store constants that can include addresses. To avoid problems we only use a move if the value is zero or odd and so looks like a tagged value. *) val storeAble = case value of BICConstnt(value, _) => if not(isShort value) then NONE else let val ival = Word.toLargeIntX(toShort value) in if targetArch = Native64Bit then if is32bit ival then SOME ival else NONE else if ival = 0 orelse ival mod 2 = 1 then SOME ival else NONE end | _ => NONE val (storeVal, valCode) = case storeAble of SOME value => (IntegerConstant value (* Leave untagged *), []) | NONE => let val valueReg = newPReg() and valueReg1 = newUReg() in (RegisterArgument valueReg1, codeToICodeTarget(value, context, false, valueReg) @ [BlockSimple(UntagValue{dest=valueReg1, source=valueReg, isSigned=false, cache=NONE, opSize=polyWordOpSize})]) end val code = codeBaseIndex @ valCode @ codeUntag @ [BlockSimple(StoreArgument {source=storeVal, base=base, offset=offset, index=index, kind=movePolyWord, isMutable=true})] in moveIfNotAllowed(destination, code, (* Unit result *) IntegerConstant(tag 0)) end and codeToICodeBlock({kind=BlockOpCompareByte, sourceLeft, destRight, length}, context, _, destination) = let (* This is effectively a big-endian comparison since we compare the bytes until we find an inequality. *) val target = asTarget destination val mergeResult = newMergeReg() val vec1Reg = newUReg() and vec2Reg = newUReg() val (leftCode, leftUntag, {base=leftBase, offset=leftOffset, index=leftIndex, ...}) = codeAddress(sourceLeft, true, context) val (rightCode, rightUntag, {base=rightBase, offset=rightOffset, index=rightIndex, ...}) = codeAddress(destRight, true, context) val ccRef = newCCRef() val labLess = newLabel() and labGreater = newLabel() and exitLab = newLabel() val labNotLess = newLabel() and labNotGreater = newLabel() val (lengthCode, lengthUntag, lengthArg) = codeAsUntaggedToReg(length, false (* unsigned *), context) val code = leftCode @ rightCode @ lengthCode @ leftUntag @ [BlockSimple(loadAddress{base=leftBase, offset=leftOffset, index=leftIndex, dest=vec1Reg})] @ rightUntag @ [BlockSimple(loadAddress{base=rightBase, offset=rightOffset, index=rightIndex, dest=vec2Reg})] @ lengthUntag @ [BlockSimple(CompareByteVectors{ vec1Addr=vec1Reg, vec2Addr=vec2Reg, length=lengthArg, ccRef=ccRef }), (* N.B. These are unsigned comparisons. *) BlockFlow(Conditional{ ccRef=ccRef, condition=JB, trueJump=labLess, falseJump=labNotLess }), BlockLabel labNotLess, BlockFlow(Conditional{ ccRef=ccRef, condition=JA, trueJump=labGreater, falseJump=labNotGreater }), BlockLabel labNotGreater, BlockSimple(LoadArgument{ source=IntegerConstant(tag 0), dest=mergeResult, kind=movePolyWord }), BlockFlow(Unconditional exitLab), BlockLabel labLess, BlockSimple(LoadArgument{ source=IntegerConstant(tag ~1), dest=mergeResult, kind=movePolyWord }), BlockFlow(Unconditional exitLab), BlockLabel labGreater, BlockSimple(LoadArgument{ source=IntegerConstant(tag 1), dest=mergeResult, kind=movePolyWord }), BlockLabel exitLab, BlockSimple(LoadArgument{ source=RegisterArgument mergeResult, dest=target, kind=movePolyWord })] in (code, RegisterArgument target, false) end | codeToICodeBlock({kind=BlockOpMove {isByteMove}, sourceLeft, destRight, length}, context, _, destination) = let (* Moves of 4 or 8 bytes can be done as word moves provided the alignment is correct. Although this will work for strings it is really to handle moves between SysWord and volatileRef in Foreign.Memory. Moves of 1, 2 or 3 bytes or words are converted into a sequence of byte or word moves. *) val isWordMove = case (isByteMove, length) of (true, BICConstnt(l, _)) => if not (isShort l) orelse (toShort l <> 0w4 andalso toShort l <> nativeWordSize) then NONE else let val leng = Word.toInt(toShort l) val moveKind = if toShort l = nativeWordSize then moveNativeWord else Move32Bit val isLeftAligned = case sourceLeft of {index=NONE, offset:int, ...} => offset mod leng = 0 | _ => false val isRightAligned = case destRight of {index=NONE, offset: int, ...} => offset mod leng = 0 | _ => false in if isLeftAligned andalso isRightAligned then SOME moveKind else NONE end | _ => NONE in case isWordMove of SOME moveKind => let val (leftCode, leftUntag, leftMem) = codeAddress(sourceLeft, isByteMove, context) val (rightCode, rightUntag, {base, offset, index, ...}) = codeAddress(destRight, isByteMove, context) val untaggedResReg = newUReg() val code = leftCode @ rightCode @ leftUntag @ rightUntag @ [BlockSimple(LoadArgument { source=MemoryLocation leftMem, dest=untaggedResReg, kind=moveKind}), BlockSimple(StoreArgument {source=RegisterArgument untaggedResReg, base=base, offset=offset, index=index, kind=moveKind, isMutable=true})] in moveIfNotAllowed(destination, code, (* Unit result *) IntegerConstant(tag 0)) end | _ => let val vec1Reg = newUReg() and vec2Reg = newUReg() val (leftCode, leftUntag, {base=leftBase, offset=leftOffset, index=leftIndex, ...}) = codeAddress(sourceLeft, isByteMove, context) val (rightCode, rightUntag, {base=rightBase, offset=rightOffset, index=rightIndex, ...}) = codeAddress(destRight, isByteMove, context) val (lengthCode, lengthUntag, lengthArg) = codeAsUntaggedToReg(length, false (* unsigned *), context) val code = leftCode @ rightCode @ lengthCode @ leftUntag @ [BlockSimple(loadAddress{base=leftBase, offset=leftOffset, index=leftIndex, dest=vec1Reg})] @ rightUntag @ [BlockSimple(loadAddress{base=rightBase, offset=rightOffset, index=rightIndex, dest=vec2Reg})] @ lengthUntag @ [BlockSimple(BlockMove{ srcAddr=vec1Reg, destAddr=vec2Reg, length=lengthArg, isByteMove=isByteMove })] in moveIfNotAllowed(destination, code, (* Unit result *) IntegerConstant(tag 0)) end end | codeToICodeBlock({kind=BlockOpEqualByte, ...}, _, _, _) = (* TODO: Move the code from codeToICodeRev. However, that is already reversed. *) raise InternalError "codeToICodeBlock - BlockOpEqualByte" (* Already done *) and codeConditionRev(condition, context, jumpOn, jumpLabel, tailCode) = (* General case. Load the value into a register and compare it with 1 (true) *) let val ccRef = newCCRef() val (testCode, testReg) = codeToPRegRev(condition, context, tailCode) val noJumpLabel = newLabel() in BlockLabel noJumpLabel :: BlockFlow(Conditional{ccRef=ccRef, condition=if jumpOn then JE else JNE, trueJump=jumpLabel, falseJump=noJumpLabel}) :: BlockSimple(CompareLiteral{arg1=RegisterArgument testReg, arg2=tag 1, opSize=OpSize32, ccRef=ccRef}) :: testCode end (* The fixed precision functions are also used for arbitrary precision but instead of raising Overflow we need to jump to the code that handles the long format. *) and codeFixedPrecisionArith(BuiltIns.ArithAdd, arg1, BICConstnt(value, _), context, target, onOverflow) = let val ccRef = newCCRef() (* If the argument is a constant we can subtract the tag beforehand. This should always be a tagged value if the type is correct. However it's possible for it not to be if we have an arbitrary precision value. There will be a run-time check that the value is short and so this code will never be executed. It will generally be edited out by the higher level be we can't rely on that. Because it's never executed we can just put in zero. *) val constVal = if isShort value then semitag(Word.toLargeIntX(toShort value)) else 0 val (arg1Code, aReg1) = codeToPReg(arg1, context) in arg1Code @ [BlockSimple(ArithmeticFunction{oper=ADD, resultReg=target, operand1=aReg1, operand2=IntegerConstant constVal, ccRef=ccRef, opSize=polyWordOpSize})] @ onOverflow ccRef end | codeFixedPrecisionArith(BuiltIns.ArithAdd, BICConstnt(value, _), arg2, context, target, onOverflow) = let val ccRef = newCCRef() (* If the argument is a constant we can subtract the tag beforehand. Check for short - see comment above. *) val constVal = if isShort value then semitag(Word.toLargeIntX(toShort value)) else 0 val (arg2Code, aReg2) = codeToPReg(arg2, context) in arg2Code @ [BlockSimple(ArithmeticFunction{oper=ADD, resultReg=target, operand1=aReg2, operand2=IntegerConstant constVal, ccRef=ccRef, opSize=polyWordOpSize})] @ onOverflow ccRef end | codeFixedPrecisionArith(BuiltIns.ArithAdd, arg1, arg2, context, target, onOverflow) = let val aReg3 = newPReg() and ccRef = newCCRef() val (arg1Code, aReg1) = codeToPReg(arg1, context) val (arg2Code, aReg2) = codeToPReg(arg2, context) in arg1Code @ arg2Code @ (* Subtract the tag bit from the second argument, do the addition and check for overflow. *) (* TODO: We should really do the detagging in the transform phase. It can make a better choice of the argument if one of the arguments is already untagged or if we have a constant argument. *) [BlockSimple(ArithmeticFunction{oper=SUB, resultReg=aReg3, operand1=aReg1, operand2=IntegerConstant 1, ccRef=newCCRef(), opSize=polyWordOpSize}), BlockSimple(ArithmeticFunction{oper=ADD, resultReg=target, operand1=aReg3, operand2=RegisterArgument aReg2, ccRef=ccRef, opSize=polyWordOpSize})] @ onOverflow ccRef end (* Subtraction. We can handle the special case of the second argument being a constant but not the first. *) | codeFixedPrecisionArith(BuiltIns.ArithSub, arg1, BICConstnt(value, _), context, target, onOverflow) = let val ccRef = newCCRef() (* If the argument is a constant we can subtract the tag beforehand. Check for short - see comment above. *) val constVal = if isShort value then semitag(Word.toLargeIntX(toShort value)) else 0 val (arg1Code, aReg1) = codeToPReg(arg1, context) in arg1Code @ [BlockSimple(ArithmeticFunction{oper=SUB, resultReg=target, operand1=aReg1, operand2=IntegerConstant constVal, ccRef=ccRef, opSize=polyWordOpSize})] @ onOverflow ccRef end | codeFixedPrecisionArith(BuiltIns.ArithSub, arg1, arg2, context, target, onOverflow) = let val aReg3 = newPReg() val ccRef = newCCRef() val (arg1Code, aReg1) = codeToPReg(arg1, context) val (arg2Code, aReg2) = codeToPReg(arg2, context) in arg1Code @ arg2Code @ (* Do the subtraction, test for overflow and afterwards add in the tag bit. *) [BlockSimple(ArithmeticFunction{oper=SUB, resultReg=aReg3, operand1=aReg1, operand2=RegisterArgument aReg2, ccRef=ccRef, opSize=polyWordOpSize})] @ onOverflow ccRef @ [BlockSimple(ArithmeticFunction{oper=ADD, resultReg=target, operand1=aReg3, operand2=IntegerConstant 1, ccRef=newCCRef(), opSize=polyWordOpSize})] end | codeFixedPrecisionArith(BuiltIns.ArithMult, arg1, BICConstnt(value, _), context, target, onOverflow) = let val aReg = newPReg() and argUntagged = newUReg() and resUntagged = newUReg() val mulCC = newCCRef() (* Is it better to untag the constant or the register argument? *) val constVal = if isShort value then Word.toLargeIntX(toShort value) else 0 in codeToICodeTarget(arg1, context, false, aReg) @ [BlockSimple(ArithmeticFunction{oper=SUB, resultReg=argUntagged, operand1=aReg, operand2=IntegerConstant 1, ccRef=newCCRef(), opSize=polyWordOpSize}), BlockSimple(Multiplication{resultReg=resUntagged, operand1=argUntagged, operand2=IntegerConstant constVal, ccRef=mulCC, opSize=polyWordOpSize} )] @ onOverflow mulCC @ [BlockSimple(ArithmeticFunction{oper=ADD, resultReg=target, operand1=resUntagged, operand2=IntegerConstant 1, ccRef=newCCRef(), opSize=polyWordOpSize})] end | codeFixedPrecisionArith(BuiltIns.ArithMult, BICConstnt(value, _), arg2, context, target, onOverflow) = let val aReg = newPReg() and argUntagged = newUReg() and resUntagged = newUReg() val mulCC = newCCRef() (* Is it better to untag the constant or the register argument? *) val constVal = if isShort value then Word.toLargeIntX(toShort value) else 0 in codeToICodeTarget(arg2, context, false, aReg) @ [BlockSimple(ArithmeticFunction{oper=SUB, resultReg=argUntagged, operand1=aReg, operand2=IntegerConstant 1, ccRef=newCCRef(), opSize=polyWordOpSize}), BlockSimple(Multiplication{resultReg=resUntagged, operand1=argUntagged, operand2=IntegerConstant constVal, ccRef=mulCC, opSize=polyWordOpSize} )] @ onOverflow mulCC @ [BlockSimple(ArithmeticFunction{oper=ADD, resultReg=target, operand1=resUntagged, operand2=IntegerConstant 1, ccRef=newCCRef(), opSize=polyWordOpSize})] end | codeFixedPrecisionArith(BuiltIns.ArithMult, arg1, arg2, context, target, onOverflow) = let val aReg1 = newPReg() and aReg2 = newPReg() and arg1Untagged = newUReg() and arg2Untagged = newUReg() and resUntagged = newUReg() val mulCC = newCCRef() (* This is almost the same as the word operation except we use a signed shift and check for overflow. *) in codeToICodeTarget(arg1, context, false, aReg1) @ codeToICodeTarget(arg2, context, false, aReg2) @ (* Shift one argument and subtract the tag from the other. It's possible this could be reordered if we have a value that is already untagged. *) [BlockSimple(UntagValue{source=aReg1, dest=arg1Untagged, isSigned=true (* Signed shift here. *), cache=NONE, opSize=polyWordOpSize}), BlockSimple(ArithmeticFunction{oper=SUB, resultReg=arg2Untagged, operand1=aReg2, operand2=IntegerConstant 1, ccRef=newCCRef(), opSize=polyWordOpSize}), BlockSimple(Multiplication{resultReg=resUntagged, operand1=arg1Untagged, operand2=RegisterArgument arg2Untagged, ccRef=mulCC, opSize=polyWordOpSize} )] @ onOverflow mulCC @ [BlockSimple(ArithmeticFunction{oper=ADD, resultReg=target, operand1=resUntagged, operand2=IntegerConstant 1, ccRef=newCCRef(), opSize=polyWordOpSize})] end | codeFixedPrecisionArith(BuiltIns.ArithQuot, arg1, arg2, context, target, _) = let val aReg1 = newPReg() and aReg2 = newPReg() val arg1Untagged = newUReg() and arg2Untagged = newUReg() val quotient = newUReg() and remainder = newUReg() in codeToICodeTarget(arg1, context, false, aReg1) @ codeToICodeTarget(arg2, context, false, aReg2) @ (* Shift both of the arguments to remove the tags. We don't test for zero here - that's done explicitly. *) [BlockSimple(UntagValue{source=aReg1, dest=arg1Untagged, isSigned=true, cache=NONE, opSize=polyWordOpSize}), BlockSimple(UntagValue{source=aReg2, dest=arg2Untagged, isSigned=true, cache=NONE, opSize=polyWordOpSize}), BlockSimple(Division { isSigned = true, dividend=arg1Untagged, divisor=RegisterArgument arg2Untagged, quotient=quotient, remainder=remainder, opSize=polyWordOpSize }), BlockSimple(TagValue { source=quotient, dest=target, isSigned=true, opSize=polyWordOpSize})] end | codeFixedPrecisionArith(BuiltIns.ArithRem, arg1, arg2, context, target, _) = let (* Identical to Quot except that the result is the remainder. *) val aReg1 = newPReg() and aReg2 = newPReg() val arg1Untagged = newUReg() and arg2Untagged = newUReg() val quotient = newUReg() and remainder = newUReg() in codeToICodeTarget(arg1, context, false, aReg1) @ codeToICodeTarget(arg2, context, false, aReg2) @ (* Shift both of the arguments to remove the tags. *) [BlockSimple(UntagValue{source=aReg1, dest=arg1Untagged, isSigned=true, cache=NONE, opSize=polyWordOpSize}), BlockSimple(UntagValue{source=aReg2, dest=arg2Untagged, isSigned=true, cache=NONE, opSize=polyWordOpSize}), BlockSimple(Division { isSigned = true, dividend=arg1Untagged, divisor=RegisterArgument arg2Untagged, quotient=quotient, remainder=remainder, opSize=polyWordOpSize }), BlockSimple(TagValue { source=remainder, dest=target, isSigned=true, opSize=polyWordOpSize})] end | codeFixedPrecisionArith(_, _, _, _, _, _) = raise InternalError "codeToICode: FixedPrecisionArith - unimplemented operation" (* Generate code for floating point arguments where one of the arguments must be in a register. If the first argument is in a register use that, if the second is in a register and it's commutative use that otherwise load the first argument into a register. *) and codeFPBinaryArgsRev(arg1, arg2, precision, commutative, context, tailCode) = let val (arg1Code, arg1Value) = codeFPArgument(arg1, precision, context, tailCode) val (arg2Code, arg2Value) = codeFPArgument(arg2, precision, context, arg1Code) in case (arg1Value, arg2Value, commutative) of (RegisterArgument fpReg, _, _) => (arg2Code, fpReg, arg2Value) | (_, RegisterArgument fpReg, Commutative) => (arg2Code, fpReg, arg1Value) | (arg1Val, _, _) => let val fpReg = newUReg() val moveOp = case precision of BuiltIns.PrecDouble => MoveDouble | BuiltIns.PrecSingle => MoveFloat in (BlockSimple(LoadArgument{source=arg1Val, dest=fpReg, kind=moveOp}) :: arg2Code, fpReg, arg2Value) end end (* Generate code to evaluate a floating point argument. The aim of this code is to avoid the overhead of untagging a short-precision floating point value in memory. *) and codeFPArgument(BICConstnt(value, _), _, _, tailCode) = let val argVal = (* Single precision constants in 64-bit mode are represented by the value shifted left 32 bits. A word is shifted left one bit so the result is 0w31. *) if isShort value then IntegerConstant(Word.toLargeInt(Word.>>(toShort value, 0w31))) else AddressConstant value in (tailCode, argVal) end | codeFPArgument(arg, precision, context, tailCode) = ( case (precision, wordSize) of (BuiltIns.PrecSingle, 0w8) => (* If this is a single precision value and the word size is 8 the values are tagged. If it is memory we can load the value directly from the high-order word. *) let val memOrReg = { anyConstant=false, const32s=false, memAddr=true, existingPreg=true } val (code, result, _) = codeToICodeRev(arg, context, false, Allowed memOrReg, tailCode) in case result of RegisterArgument argReg => let val fpReg = newUReg() in (BlockSimple(UntagFloat{source=RegisterArgument argReg, dest=fpReg, cache=NONE}) :: code, RegisterArgument fpReg) end | MemoryLocation{offset, base, index, ...} => (code, MemoryLocation{offset=offset+4, base=base, index=index, cache=NONE}) | _ => raise InternalError "codeFPArgument" end | _ => (* Otherwise the value is boxed. *) let val (argCode, argReg) = codeToPRegRev(arg, context, tailCode) in (argCode, wordAt argReg) end ) (* Code an address. The index is optional. *) and codeAddressRev({base, index=SOME index, offset}, true (* byte move *), context, tailCode) = let (* Byte address with index. The index needs to be untagged. *) val indexReg1 = newUReg() val (codeBase, baseReg) = codeToPRegRev(base, context, tailCode) val (codeIndex, indexReg) = codeToPRegRev(index, context, codeBase) val untagCode = [BlockSimple(UntagValue{dest=indexReg1, source=indexReg, isSigned=false, cache=NONE, opSize=polyWordOpSize})] val (codeLoadAddr, realBase) = if targetArch = ObjectId32Bit then let val addrReg = newUReg() in ([BlockSimple(LoadEffectiveAddress{ base=SOME baseReg, offset=0, index=ObjectIndex, dest=addrReg, opSize=nativeWordOpSize})], addrReg) end else ([], baseReg) val memResult = {base=realBase, offset=offset, index=MemIndex1 indexReg1, cache=NONE} in (codeLoadAddr @ codeIndex, untagCode, memResult) end | codeAddressRev({base, index=SOME index, offset}, false (* word move *), context, tailCode) = let (* Word address with index. We can avoid untagging the index by adjusting the multiplier and offset *) val (codeBase, baseReg) = codeToPRegRev(base, context, tailCode) val (codeIndex, indexReg) = codeToPRegRev(index, context, codeBase) val (codeLoadAddr, realBase) = if targetArch = ObjectId32Bit then let val addrReg = newUReg() in ([BlockSimple(LoadEffectiveAddress{ base=SOME baseReg, offset=0, index=ObjectIndex, dest=addrReg, opSize=nativeWordOpSize})], addrReg) end else ([], baseReg) val memResult = if wordSize = 0w8 then {base=realBase, offset=offset-4, index=MemIndex4 indexReg, cache=NONE} else {base=realBase, offset=offset-2, index=MemIndex2 indexReg, cache=NONE} in (codeLoadAddr @ codeIndex, [], memResult) end | codeAddressRev({base, index=NONE, offset}, _, context, tailCode) = let val (codeBase, baseReg) = codeToPRegRev(base, context, tailCode) val memResult = {offset=offset, base=baseReg, index=memIndexOrObject, cache=NONE} in (codeBase, [], memResult) end and codeAddress(addr, isByte, context) = let val (code, untag, res) = codeAddressRev(addr, isByte, context, []) in (List.rev code, untag, res) end (* C-memory operations are slightly different. The base address is a LargeWord.word value. The index is a byte index so may have to be untagged. *) and codeCAddress({base, index=SOME index, offset}, 0w1, context) = let (* Byte address with index. The index needs to be untagged. *) val untaggedBaseReg = newUReg() val (codeBase, baseReg) = codeToPReg(base, context) and (codeIndex, indexReg) = codeToPReg(index, context) (* The index needs to untagged and, if necessary, sign-extended to the native word size. *) val (untagCode, sxReg) = if targetArch = ObjectId32Bit then let val sReg1 = newUReg() and sReg2 = newUReg() in ([BlockSimple(SignExtend32To64{dest=sReg1, source=RegisterArgument indexReg}), BlockSimple(UntagValue{dest=sReg2, source=sReg1, isSigned=true, cache=NONE, opSize=nativeWordOpSize})], sReg2) end else let val sReg = newUReg() in ([BlockSimple(UntagValue{dest=sReg, source=indexReg, isSigned=true, cache=NONE, opSize=nativeWordOpSize})], sReg) end val loadCode = [BlockSimple(LoadArgument{source=wordAt baseReg, dest=untaggedBaseReg, kind=moveNativeWord})] val memResult = {base=untaggedBaseReg, offset=offset, index=MemIndex1 sxReg, cache=NONE} in (codeBase @ codeIndex, loadCode @ untagCode, memResult) end | codeCAddress({base, index=SOME index, offset}, size, context) = let (* Non-byte address with index. By using an appropriate multiplier we can avoid having to untag the index. *) val untaggedBaseReg = newUReg() val (codeBase, baseReg) = codeToPReg(base, context) and (codeIndex, indexReg) = codeToPReg(index, context) (* The index is signed i.e. negative index values are legal. We don't have to do anything special on the native code versions but on 32-in-64 we need to sign extend. *) val (untagCode, sxReg) = if targetArch = ObjectId32Bit then let val sReg = newUReg() in ([BlockSimple(SignExtend32To64{source=RegisterArgument indexReg, dest=sReg})], sReg) end else ([], indexReg) val loadCode = [BlockSimple(LoadArgument{source=wordAt baseReg, dest=untaggedBaseReg, kind=moveNativeWord})] val memResult = case size of 0w2 => {base=untaggedBaseReg, offset=offset-1, index=MemIndex1 sxReg, cache=NONE} | 0w4 => {base=untaggedBaseReg, offset=offset-2, index=MemIndex2 sxReg, cache=NONE} | 0w8 => {base=untaggedBaseReg, offset=offset-4, index=MemIndex4 sxReg, cache=NONE} | _ => raise InternalError "codeCAddress: unknown size" in (codeBase @ codeIndex, loadCode @ untagCode, memResult) end | codeCAddress({base, index=NONE, offset}, _, context) = let val untaggedBaseReg = newUReg() val (codeBase, baseReg) = codeToPReg(base, context) val untagCode = [BlockSimple(LoadArgument{source=wordAt baseReg, dest=untaggedBaseReg, kind=moveNativeWord})] val memResult = {offset=offset, base=untaggedBaseReg, index=NoMemIndex, cache=NONE} in (codeBase, untagCode, memResult) end (* Return an untagged value. If we have a constant just return it. Otherwise return the code to evaluate the argument, the code to untag it and the reference to the untagged register. *) and codeAsUntaggedToRegRev(BICConstnt(value, _), isSigned, _, tailCode) = let (* Should always be short except for unreachable code. *) val untagReg = newUReg() val cval = if isShort value then toShort value else 0w0 val cArg = IntegerConstant(if isSigned then Word.toLargeIntX cval else Word.toLargeInt cval) (* Don't tag *) val untag = [BlockSimple(LoadArgument{source=cArg, dest=untagReg, kind=movePolyWord})] in (tailCode, untag, untagReg) (* Don't tag. *) end | codeAsUntaggedToRegRev(arg, isSigned, context, tailCode) = let val untagReg = newUReg() val (code, srcReg) = codeToPRegRev(arg, context, tailCode) val untag = [BlockSimple(UntagValue{source=srcReg, dest=untagReg, isSigned=isSigned, cache=NONE, opSize=polyWordOpSize})] in (code, untag, untagReg) end and codeAsUntaggedToReg(arg, isSigned, context) = let val (code, untag, untagReg) = codeAsUntaggedToRegRev(arg, isSigned, context, []) in (List.rev code, untag, untagReg) end (* Return the argument as an untagged value. We separate evaluating the argument from untagging because we may have to evaluate other arguments and that could involve a function call and we can't save the value to the stack after we've untagged it. Currently this is only used for byte values but we may have to be careful if we use it for word values on the X86. Moving an untagged value into a register might look like loading a constant address. *) and codeAsUntaggedByte(BICConstnt(value, _), isSigned, _) = let val cval = if isShort value then toShort value else 0w0 val cArg = IntegerConstant(if isSigned then Word.toLargeIntX cval else Word.toLargeInt cval) (* Don't tag *) in ([], [], cArg) end | codeAsUntaggedByte(arg, isSigned, context) = let val untagReg = newUReg() val (code, argReg) = codeToPReg(arg, context) val untag = [BlockSimple(UntagValue{source=argReg, dest=untagReg, isSigned=isSigned, cache=NONE, opSize=OpSize32})] in (code, untag, RegisterArgument untagReg) end (* Allocate memory. This is used both for true variable length cells and also for longer constant length cells. *) and allocateMemoryVariable(numWords, flags, initial, context, destination) = let val target = asTarget destination (* With the exception of flagReg all these registers are modified by the code. So, we have to copy the size value into a new register. *) val sizeReg = newPReg() and initReg = newPReg() val sizeReg2 = newPReg() val untagSizeReg = newUReg() and initAddrReg = newPReg() and allocReg = newPReg() val sizeCode = codeToICodeTarget(numWords, context, false, sizeReg) and (flagsCode, flagUntag, flagArg) = codeAsUntaggedByte(flags, false, context) (* We're better off deferring the initialiser if possible. If the value is a constant we don't have to save it. *) val (initCode, initResult, _) = codeToICode(initial, context, false, Allowed allowDefer) in (sizeCode @ flagsCode @ initCode @ [(* We need to copy the size here because AllocateMemoryVariable modifies the size in order to store the length word. This is unfortunate especially as we're going to untag it anyway. *) BlockSimple(LoadArgument{source=RegisterArgument sizeReg, dest=sizeReg2, kind=movePolyWord}), BlockSimple(AllocateMemoryVariable{size=sizeReg, dest=allocReg, saveRegs=[]})] @ flagUntag @ [BlockSimple(StoreArgument{ source=flagArg, base=allocReg, offset= ~1, index=memIndexOrObject, kind=MoveByte, isMutable=false}), (* We need to copy the address here because InitialiseMem modifies all its arguments. *) BlockSimple( if targetArch = ObjectId32Bit then LoadEffectiveAddress{ base=SOME allocReg, offset=0, index=ObjectIndex, dest=initAddrReg, opSize=nativeWordOpSize} else LoadArgument{source=RegisterArgument allocReg, dest=initAddrReg, kind=movePolyWord}), BlockSimple(UntagValue{source=sizeReg2, dest=untagSizeReg, isSigned=false, cache=NONE, opSize=polyWordOpSize}), BlockSimple(LoadArgument{source=initResult, dest=initReg, kind=movePolyWord}), BlockSimple(InitialiseMem{size=untagSizeReg, init=initReg, addr=initAddrReg}), BlockSimple InitialisationComplete, BlockSimple(LoadArgument{source=RegisterArgument allocReg, dest=target, kind=movePolyWord})], RegisterArgument target, false) end (*Turn the codetree structure into icode. *) val bodyContext = {loopArgs=NONE, stackPtr=0, currHandler=NONE, overflowBlock=ref NONE} val (bodyCode, _, bodyExited) = codeToICodeRev(body, bodyContext, true, SpecificPReg resultTarget, beginInstructions) val icode = if bodyExited then bodyCode else returnInstruction(bodyContext, resultTarget, bodyCode) (* Turn the icode list into basic blocks. The input list is in reverse so as part of this we reverse the list. *) local val resArray = Array.array(!labelCounter, BasicBlock{ block=[], flow=ExitCode }) fun createEntry (blockNo, block, flow) = Array.update(resArray, blockNo, BasicBlock{ block=block, flow=flow}) fun splitCode([], _, _) = (* End of code. We should have had a BeginFunction. *) raise InternalError "splitCode - no begin" | splitCode(BlockBegin args :: _, sinceLabel, flow) = (* Final instruction. Create the initial block and exit. *) createEntry(0, BeginFunction args ::sinceLabel, flow) | splitCode(BlockSimple instr :: rest, sinceLabel, flow) = splitCode(rest, instr :: sinceLabel, flow) | splitCode(BlockLabel label :: rest, sinceLabel, flow) = (* Label - finish this block and start another. *) ( createEntry(label, sinceLabel, flow); (* Default to a jump to this label. That is used if we have assumed a drop-through. *) splitCode(rest, [], Unconditional label) ) | splitCode(BlockExit instr :: rest, _, _) = splitCode(rest, [instr], ExitCode) | splitCode(BlockFlow flow :: rest, _, _) = splitCode(rest, [], flow) | splitCode(BlockRaiseAndHandle(instr, handler) :: rest, _, _) = splitCode(rest, [instr], UnconditionalHandle handler) | splitCode(BlockOptionalHandle{call, handler, label} :: rest, sinceLabel, flow) = let (* A function call within a handler. This could go to the handler but if there is no exception will go to the next instruction. Also includes JumpLoop since the stack check could result in an Interrupt exception. *) in createEntry(label, sinceLabel, flow); splitCode(rest, [call], ConditionalHandle{handler=handler, continue=label}) end in val () = splitCode(icode, [], ExitCode) val resultVector = Array.vector resArray end open ICODETRANSFORM val pregProperties = Vector.fromList(List.rev(! pregPropList)) in codeICodeFunctionToX86{blocks = resultVector, functionName = name, pregProps = pregProperties, ccCount= ! ccRefCounter, debugSwitches = debugSwitches, resultClosure = resultClosure} end fun gencodeLambda(lambda, debugSwitches, closure) = let open DEBUG Universal (*val debugSwitches = [tagInject Pretty.compilerOutputTag (Pretty.prettyPrint(print, 70)), tagInject assemblyCodeTag true] @ debugSwitches*) in codeFunctionToX86(lambda, debugSwitches, closure) end structure Foreign = X86FOREIGN structure Sharing = struct type backendIC = backendIC and bicLoadForm = bicLoadForm and argumentType = argumentType and closureRef = closureRef end end; diff --git a/mlsource/MLCompiler/CodeTree/X86Code/X86FOREIGNCALL.sml b/mlsource/MLCompiler/CodeTree/X86Code/X86FOREIGNCALL.sml index 08c792dd..a0370d76 100644 --- a/mlsource/MLCompiler/CodeTree/X86Code/X86FOREIGNCALL.sml +++ b/mlsource/MLCompiler/CodeTree/X86Code/X86FOREIGNCALL.sml @@ -1,1724 +1,1724 @@ (* Copyright (c) 2016-20 David C.J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) functor X86FOREIGNCALL( structure X86CODE: X86CODESIG structure X86OPTIMISE: sig type operation type code type operations = operation list type closureRef (* Optimise and code-generate. *) val generateCode: {code: code, ops: operations, labelCount: int, resultClosure: closureRef} -> unit structure Sharing: sig type operation = operation type code = code type closureRef = closureRef end end - structure DEBUG: DEBUGSIG + structure DEBUG: DEBUG structure CODE_ARRAY: CODEARRAYSIG sharing X86CODE.Sharing = X86OPTIMISE.Sharing = CODE_ARRAY.Sharing ): FOREIGNCALLSIG = struct open X86CODE open Address open CODE_ARRAY (* Unix X64. The first six arguments are in rdi, rsi, rdx, rcx, r8, r9. The rest are on the stack. Windows X64. The first four arguments are in rcx, rdx, r8 and r9. The rest are on the stack. The caller must ensure the stack is aligned on 16-byte boundary and must allocate 32-byte save area for the register args. rbx, rbp, rdi, rsi, rsp, r12-r15 are saved by the called function. X86/32. Arguments are pushed to the stack. ebx, edi, esi, ebp and esp are saved by the called function. We use esi to hold the argument data pointer and edi to save the ML stack pointer Our ML conventions use eax, ebx for the first two arguments in X86/32, rax, ebx, r8, r9, r10 for the first five arguments in X86/64 and rax, rsi, r8, r9 and r10 for the first five arguments in X86/64-32 bit. *) val memRegSize = 0 val (polyWordOpSize, nativeWordOpSize) = case targetArch of Native32Bit => (OpSize32, OpSize32) | Native64Bit => (OpSize64, OpSize64) | ObjectId32Bit => (OpSize32, OpSize64) (* Ebx/Rbx is used for the second argument on the native architectures but is replaced by esi on the object ID arch because ebx is used as the global base register. *) val mlArg2Reg = case targetArch of ObjectId32Bit => esi | _ => ebx exception InternalError = Misc.InternalError fun opSizeToMove OpSize32 = Move32 | opSizeToMove OpSize64 = Move64 val pushR = PushToStack o RegisterArg fun moveRR{source, output, opSize} = Move{source=RegisterArg source, destination=RegisterArg output, moveSize=opSizeToMove opSize} fun loadMemory(reg, base, offset, opSize) = Move{source=MemoryArg{base=base, offset=offset, index=NoIndex}, destination=RegisterArg reg, moveSize=opSizeToMove opSize} and storeMemory(reg, base, offset, opSize) = Move{source=RegisterArg reg, destination=MemoryArg {base=base, offset=offset, index=NoIndex}, moveSize=opSizeToMove opSize} val loadHeapMemory = case targetArch of ObjectId32Bit => ( fn (reg, base, offset, opSize) => Move{source=MemoryArg{base=ebx, offset=offset, index=Index4 base}, destination=RegisterArg reg, moveSize=opSizeToMove opSize} ) | _ => loadMemory fun loadAddress{source=(srcReg, 0), destination} = Move{source=RegisterArg srcReg, destination=RegisterArg destination, moveSize=opSizeToMove nativeWordOpSize} | loadAddress{source=(srcReg, srcOffset), destination} = LoadAddress{offset=srcOffset, base=SOME srcReg, index=NoIndex, output=destination, opSize=nativeWordOpSize } (* Sequence of operations to move memory. *) fun moveMemory{source, destination, length} = [ loadAddress{source=source, destination=rsi}, loadAddress{source=destination, destination=rdi}, (* N.B. When moving a struct in a Win64 callback the source could be rcx so only move this after copying the source to rsi. *) Move{source=NonAddressConstArg(LargeInt.fromInt length), destination=RegisterArg rcx, moveSize=opSizeToMove nativeWordOpSize}, RepeatOperation MOVS8 ] fun createProfileObject _ (*functionName*) = let (* The profile object is a single mutable with the F_bytes bit set. *) open Address val profileObject = RunCall.allocateByteMemory(0w1, Word.fromLargeWord(Word8.toLargeWord(Word8.orb(F_mutable, F_bytes)))) fun clear 0w0 = () | clear i = (assignByte(profileObject, i-0w1, 0w0); clear (i-0w1)) val () = clear wordSize in toMachineWord profileObject end val makeEntryPoint: string -> machineWord = RunCall.rtsCallFull1 "PolyCreateEntryPointObject" datatype abi = X86_32 | X64Win | X64Unix local (* Get the ABI. On 64-bit Windows and Unix use different calling conventions. *) val getABICall: unit -> int = RunCall.rtsCallFast0 "PolyGetABI" in fun getABI() = case getABICall() of 0 => X86_32 | 1 => X64Unix | 2 => X64Win | n => raise InternalError ("Unknown ABI type " ^ Int.toString n) end (* This is now the standard entry call code. *) datatype fastArgs = FastArgFixed | FastArgDouble | FastArgFloat fun rtsCallFastGeneral (functionName, argFormats, (*resultFormat*) _, debugSwitches) = let val entryPointAddr = makeEntryPoint functionName (* Get the ABI. On 64-bit Windows and Unix use different calling conventions. *) val abi = getABI() val entryPtrReg = if targetArch <> Native32Bit then r11 else ecx val nArgs = List.length argFormats local (* Compute stack space. The actual number of args passed is nArgs. *) val argSpace = case abi of X64Unix => Int.max(0, nArgs-6)*8 | X64Win => Int.max(0, nArgs-4)*8 | X86_32 => List.foldl(fn (FastArgDouble, n) => n+8 | (_, n) => n+4) 0 argFormats val align = argSpace mod 16 in (* Add sufficient space so that esp will be 16-byte aligned after we have pushed any arguments we need to push. *) val stackSpace = if align = 0 then memRegSize else memRegSize + 16 - align end (* The number of ML arguments passed on the stack. *) val mlArgsOnStack = Int.max(case abi of X86_32 => nArgs - 2 | _ => nArgs - 5, 0) val code = [ Move{source=AddressConstArg entryPointAddr, destination=RegisterArg entryPtrReg, moveSize=opSizeToMove polyWordOpSize}, (* Load the entry point ref. *) loadHeapMemory(entryPtrReg, entryPtrReg, 0, nativeWordOpSize)(* Load its value. *) ] @ ( (* Save heap ptr. This is in r15 in X86/64 *) if targetArch <> Native32Bit then [storeMemory(r15, ebp, memRegLocalMPointer, nativeWordOpSize)] (* Save heap ptr *) else [] ) @ ( if (case abi of X86_32 => nArgs >= 3 | _ => nArgs >= 6) then [moveRR{source=esp, output=edi, opSize=nativeWordOpSize}] (* Needed if we have to load from the stack. *) else [] ) @ [ storeMemory(esp, ebp, memRegStackPtr, nativeWordOpSize), (* Save ML stack and switch to C stack. *) loadMemory(esp, ebp, memRegCStackPtr, nativeWordOpSize), (* Set the stack pointer past the data on the stack. For Windows/64 add in a 32 byte save area *) ArithToGenReg{opc=SUB, output=esp, source=NonAddressConstArg(LargeInt.fromInt stackSpace), opSize=nativeWordOpSize} ] @ ( case abi of (* Set the argument registers. *) X86_32 => let fun pushReg(reg, FastArgFixed) = [pushR reg] | pushReg(reg, FastArgDouble) = (* reg contains the address of the value. This must be unboxed onto the stack. *) [ FPLoadFromMemory{address={base=reg, offset=0, index=NoIndex}, precision=DoublePrecision}, ArithToGenReg{ opc=SUB, output=esp, source=NonAddressConstArg 8, opSize=nativeWordOpSize}, FPStoreToMemory{ address={base=esp, offset=0, index=NoIndex}, precision=DoublePrecision, andPop=true } ] | pushReg(reg, FastArgFloat) = (* reg contains the address of the value. This must be unboxed onto the stack. *) [ FPLoadFromMemory{address={base=reg, offset=0, index=NoIndex}, precision=SinglePrecision}, ArithToGenReg{ opc=SUB, output=esp, source=NonAddressConstArg 4, opSize=nativeWordOpSize}, FPStoreToMemory{ address={base=esp, offset=0, index=NoIndex}, precision=SinglePrecision, andPop=true } ] (* The stack arguments have to be copied first followed by the ebx and finally eax. *) fun pushArgs (_, []) = [] | pushArgs (_, [argType]) = pushReg(eax, argType) | pushArgs (_, [arg2Type, arg1Type]) = pushReg(ebx, arg2Type) @ pushReg(eax, arg1Type) | pushArgs (n, FastArgFixed :: argTypes) = PushToStack(MemoryArg{base=edi, offset=(nArgs-n+1)* 4, index=NoIndex}) :: pushArgs(n-1, argTypes) | pushArgs (n, argType :: argTypes) = (* Use esi as a temporary register. *) loadMemory(esi, edi, (nArgs-n+1)* 4, polyWordOpSize) :: pushReg(esi, argType) @ pushArgs(n-1, argTypes) in pushArgs(nArgs, List.rev argFormats) end | X64Unix => ( if List.all (fn FastArgFixed => true | _ => false) argFormats then let fun pushArgs 0 = [] | pushArgs 1 = [moveRR{source=eax, output=edi, opSize=polyWordOpSize}] | pushArgs 2 = moveRR{source=mlArg2Reg, output=esi, opSize=polyWordOpSize} :: pushArgs 1 | pushArgs 3 = moveRR{source=r8, output=edx, opSize=polyWordOpSize} :: pushArgs 2 | pushArgs 4 = moveRR{source=r9, output=ecx, opSize=polyWordOpSize} :: pushArgs 3 | pushArgs 5 = (* We have to move r8 into edx before we can move r10 into r8 *) moveRR{source=r8, output=edx, opSize=polyWordOpSize} :: moveRR{source=r9, output=ecx, opSize=polyWordOpSize} :: moveRR{source=r10, output=r8, opSize=polyWordOpSize} :: pushArgs 2 | pushArgs 6 = (* We have to move r9 into edi before we can load r9 from the stack. *) moveRR{source=r8, output=edx, opSize=polyWordOpSize} :: moveRR{source=r9, output=ecx, opSize=polyWordOpSize} :: loadMemory(r9, edi, 8, polyWordOpSize) :: moveRR{source=r10, output=r8, opSize=polyWordOpSize} :: pushArgs 2 | pushArgs _ = raise InternalError "rtsCall: Abi/argument count not implemented" in pushArgs nArgs end else case argFormats of [] => [] | [FastArgFixed] => [ moveRR{source=eax, output=edi, opSize=polyWordOpSize} ] | [FastArgFixed, FastArgFixed] => (* Since mlArgs2Reg is esi on 32-in-64 this is redundant. *) [ moveRR{source=mlArg2Reg, output=esi, opSize=polyWordOpSize}, moveRR{source=eax, output=edi, opSize=polyWordOpSize} ] | [FastArgFixed, FastArgFixed, FastArgFixed] => [ moveRR{source=mlArg2Reg, output=esi, opSize=polyWordOpSize}, moveRR{source=eax, output=edi, opSize=polyWordOpSize}, moveRR{source=r8, output=edx, opSize=polyWordOpSize} ] | [FastArgFixed, FastArgFixed, FastArgFixed, FastArgFixed] => [ moveRR{source=mlArg2Reg, output=esi, opSize=polyWordOpSize}, moveRR{source=eax, output=edi, opSize=polyWordOpSize}, moveRR{source=r8, output=edx, opSize=polyWordOpSize}, moveRR{source=r9, output=ecx, opSize=polyWordOpSize} ] (* One "double" argument. The value needs to be unboxed. *) | [FastArgDouble] => [] (* Already in xmm0 *) (* X64 on both Windows and Unix take the first arg in xmm0 and the second in xmm1. They are already there. *) | [FastArgDouble, FastArgDouble] => [] | [FastArgDouble, FastArgFixed] => [ moveRR{source=eax, output=edi, opSize=nativeWordOpSize} ] | [FastArgFloat] => [] (* Already in xmm0 *) | [FastArgFloat, FastArgFloat] => [] (* Already in xmm0 and xmm1 *) (* One float argument and one fixed. *) | [FastArgFloat, FastArgFixed] => [moveRR{source=mlArg2Reg, output=edi, opSize=polyWordOpSize} ] | _ => raise InternalError "rtsCall: Abi/argument count not implemented" ) | X64Win => ( if List.all (fn FastArgFixed => true | _ => false) argFormats then let fun pushArgs 0 = [] | pushArgs 1 = [moveRR{source=eax, output=ecx, opSize=polyWordOpSize}] | pushArgs 2 = moveRR{source=mlArg2Reg, output=edx, opSize=polyWordOpSize} :: pushArgs 1 | pushArgs 3 = (* Already in r8 *) pushArgs 2 | pushArgs 4 = (* Already in r9, and r8 *) pushArgs 2 | pushArgs 5 = pushR r10 :: pushArgs 2 | pushArgs 6 = PushToStack(MemoryArg{base=edi, offset=8, index=NoIndex}) :: pushArgs 5 | pushArgs _ = raise InternalError "rtsCall: Abi/argument count not implemented" in pushArgs nArgs end else case argFormats of [FastArgFixed] => [ moveRR{source=eax, output=ecx, opSize=polyWordOpSize} ] | [FastArgFixed, FastArgFixed] => [ moveRR{source=eax, output=ecx, opSize=polyWordOpSize}, moveRR{source=mlArg2Reg, output=edx, opSize=polyWordOpSize} ] | [FastArgFixed, FastArgFixed, FastArgFixed] => [ moveRR{source=eax, output=ecx, opSize=polyWordOpSize}, moveRR{source=mlArg2Reg, output=edx, opSize=polyWordOpSize} (* Arg3 is already in r8. *) ] | [FastArgFixed, FastArgFixed, FastArgFixed, FastArgFixed] => [ moveRR{source=eax, output=ecx, opSize=polyWordOpSize}, moveRR{source=mlArg2Reg, output=edx, opSize=polyWordOpSize} (* Arg3 is already in r8 and arg4 in r9. *) ] | [FastArgDouble] => [ (* Already in xmm0 *) ] (* X64 on both Windows and Unix take the first arg in xmm0 and the second in xmm1. They are already there. *) | [FastArgDouble, FastArgDouble] => [ ] (* X64 on both Windows and Unix take the first arg in xmm0. On Unix the integer argument is treated as the first argument and goes into edi. On Windows it's treated as the second and goes into edx. N.B. It's also the first argument in ML so is in rax. *) | [FastArgDouble, FastArgFixed] => [ moveRR{source=eax, output=edx, opSize=nativeWordOpSize} ] | [FastArgFloat] => [] | [FastArgFloat, FastArgFloat] => [] (* Already in xmm0 and xmm1 *) | [FastArgFloat, FastArgFixed] => [moveRR{source=mlArg2Reg, output=edx, opSize=polyWordOpSize}] | _ => raise InternalError "rtsCall: Abi/argument count not implemented" ) ) @ (* For Windows/64 add in a 32 byte save area ater we've pushed any arguments. *) (case abi of X64Win => [ArithToGenReg{opc=SUB, output=esp, source=NonAddressConstArg 32, opSize=nativeWordOpSize}] | _ => []) @ [ CallAddress(RegisterArg entryPtrReg), (* Call the function *) loadMemory(esp, ebp, memRegStackPtr, nativeWordOpSize) (* Restore the ML stack pointer. *) ] @ ( if targetArch <> Native32Bit then [loadMemory(r15, ebp, memRegLocalMPointer, nativeWordOpSize) ] (* Copy back the heap ptr *) else [] ) @ [ (* Since this is an ML function we need to remove any ML stack arguments. *) ReturnFromFunction mlArgsOnStack ] val profileObject = createProfileObject functionName val newCode = codeCreate (functionName, profileObject, debugSwitches) val closure = makeConstantClosure() val () = X86OPTIMISE.generateCode{code=newCode, labelCount=0, ops=code, resultClosure=closure} in closureAsAddress closure end fun rtsCallFast (functionName, nArgs, debugSwitches) = rtsCallFastGeneral (functionName, List.tabulate(nArgs, fn _ => FastArgFixed), FastArgFixed, debugSwitches) (* RTS call with one double-precision floating point argument and a floating point result. *) fun rtsCallFastRealtoReal (functionName, debugSwitches) = rtsCallFastGeneral (functionName, [FastArgDouble], FastArgDouble, debugSwitches) (* RTS call with two double-precision floating point arguments and a floating point result. *) fun rtsCallFastRealRealtoReal (functionName, debugSwitches) = rtsCallFastGeneral (functionName, [FastArgDouble, FastArgDouble], FastArgDouble, debugSwitches) (* RTS call with one double-precision floating point argument, one fixed point argument and a floating point result. *) fun rtsCallFastRealGeneraltoReal (functionName, debugSwitches) = rtsCallFastGeneral (functionName, [FastArgDouble, FastArgFixed], FastArgDouble, debugSwitches) (* RTS call with one general (i.e. ML word) argument and a floating point result. This is used only to convert arbitrary precision values to floats. *) fun rtsCallFastGeneraltoReal (functionName, debugSwitches) = rtsCallFastGeneral (functionName, [FastArgFixed], FastArgDouble, debugSwitches) (* Operations on Real32.real values. *) fun rtsCallFastFloattoFloat (functionName, debugSwitches) = rtsCallFastGeneral (functionName, [FastArgFloat], FastArgFloat, debugSwitches) fun rtsCallFastFloatFloattoFloat (functionName, debugSwitches) = rtsCallFastGeneral (functionName, [FastArgFloat, FastArgFloat], FastArgFloat, debugSwitches) (* RTS call with one double-precision floating point argument, one fixed point argument and a floating point result. *) fun rtsCallFastFloatGeneraltoFloat (functionName, debugSwitches) = rtsCallFastGeneral (functionName, [FastArgFloat, FastArgFixed], FastArgFloat, debugSwitches) (* RTS call with one general (i.e. ML word) argument and a floating point result. This is used only to convert arbitrary precision values to floats. *) fun rtsCallFastGeneraltoFloat (functionName, debugSwitches) = rtsCallFastGeneral (functionName, [FastArgFixed], FastArgFloat, debugSwitches) datatype ffiABI = FFI_SYSV (* Unix 32 bit and Windows GCC 32-bit *) | FFI_STDCALL (* Windows 32-bit system ABI. Callee clears the stack. *) | FFI_MS_CDECL (* VS 32-bit. Same as SYSV except when returning a struct. Default on Windows including GCC in Mingw. *) | FFI_WIN64 (* Windows 64 bit *) | FFI_UNIX64 (* Unix 64 bit. libffi also implements this on X86/32. *) (* We don't include various other 32-bit Windows ABIs. *) local val getOSType: unit -> int = RunCall.rtsCallFast0 "PolyGetOSType" in (* This actually a constant since each exported saved state has a distinct ABI. However for compatibility with the interpreted version we make this a function. *) fun abiList () = case getABI() of X86_32 => [("sysv", FFI_SYSV), ("stdcall", FFI_STDCALL), ("ms_cdecl", FFI_MS_CDECL), (* Default to MS_CDECL on Windows otherwise SYSV. *) ("default", if getOSType() = 1 then FFI_MS_CDECL else FFI_SYSV)] | X64Win => [("win64", FFI_WIN64), ("default", FFI_WIN64)] | X64Unix => [("unix64", FFI_UNIX64), ("default", FFI_UNIX64)] type abi = ffiABI end fun alignUp(s, align) = Word.andb(s + align-0w1, ~ align) fun intAlignUp(s, align) = Word.toInt(alignUp(Word.fromInt s, align)) val getThreadDataCall = makeEntryPoint "PolyX86GetThreadData" local val sysWordSize = Word.toInt(nativeWordSize div wordSize) in (* Code to box an address as a SysWord.word value *) fun boxRegAsSysWord(boxReg, outputReg, saveRegs) = AllocStore{ size=sysWordSize, output=outputReg, saveRegs=saveRegs } :: ( if targetArch = Native64Bit then [ Move{source=NonAddressConstArg(LargeInt.fromInt sysWordSize), destination=MemoryArg {offset= ~ (Word.toInt wordSize), base=outputReg, index=NoIndex}, moveSize=opSizeToMove polyWordOpSize}, Move{moveSize=Move8, source=NonAddressConstArg 1 (* byte *), destination=MemoryArg {offset= ~1, base=outputReg, index=NoIndex}} ] else let val lengthWord = IntInf.orb(IntInf.fromInt sysWordSize, IntInf.<<(1, 0w24)) in [Move{source=NonAddressConstArg lengthWord, destination=MemoryArg {offset= ~ (Word.toInt wordSize), base=outputReg, index=NoIndex}, moveSize=opSizeToMove polyWordOpSize}] end ) @ Move{source=RegisterArg boxReg, destination=MemoryArg {offset=0, base=outputReg, index=NoIndex}, moveSize=opSizeToMove nativeWordOpSize} :: ( if targetArch = ObjectId32Bit then [ ArithToGenReg{ opc=SUB, output=outputReg, source=RegisterArg rbx, opSize=nativeWordOpSize }, ShiftConstant{ shiftType=SHR, output=outputReg, shift=0w2, opSize=OpSize64 } ] else [] ) @ [StoreInitialised] end (* Build a foreign call function. The arguments are the abi, the list of argument types and the result type. The result is the code of the ML function that takes three arguments: the C function to call, the arguments as a vector of C values and the address of the memory for the result. *) (* This must match the type in Foreign.LowLevel. Once this is bootstrapped we could use that type but note that this is the type we use within the compiler and we build Foreign.LowLevel AFTER compiling this. *) datatype cTypeForm = CTypeFloatingPt | CTypePointer | CTypeSignedInt | CTypeUnsignedInt | CTypeStruct of cType list | CTypeVoid withtype cType = { typeForm: cTypeForm, align: word, size: word } fun call32Bits(abi, args, result) = let (* 32-bit arguments. These all go to the stack so we can simply push them. The arguments go on the stack in reverse order. *) fun loadArgs32([], stackOffset, argOffset, code, continue) = continue(stackOffset, argOffset, code) | loadArgs32(arg::args, stackOffset, argOffset, code, continue) = let val {size, align, typeForm} = arg val newArgOffset = alignUp(argOffset, align) val baseAddr = {base=mlArg2Reg, offset=Word.toInt newArgOffset, index=NoIndex} in case (typeForm, size) of (CTypeStruct elements, _) => (* structs passed as values are recursively unpacked. *) loadArgs32(elements, stackOffset, newArgOffset (* Struct is aligned. *), code, fn (so, ao, code) => loadArgs32(args, so, ao, code, continue)) | (CTypeVoid, _) => raise Foreign.Foreign "Void cannot be used for a function argument" | (CTypeUnsignedInt, 0w1) => (* Unsigned char. *) loadArgs32(args, stackOffset+4, newArgOffset+size, Move{source=MemoryArg baseAddr, destination=RegisterArg edx, moveSize=Move8 } :: PushToStack(RegisterArg edx) :: code, continue) | (CTypeSignedInt, 0w1) => (* Signed char. *) loadArgs32(args, stackOffset+4, newArgOffset+size, Move{source=MemoryArg baseAddr, destination=RegisterArg edx, moveSize=Move8X32 } :: PushToStack(RegisterArg edx) :: code, continue) | (CTypeUnsignedInt, 0w2) => (* Unsigned 16-bits. *) loadArgs32(args, stackOffset+4, newArgOffset+size, Move{source=MemoryArg baseAddr, destination=RegisterArg edx, moveSize=Move16 } :: PushToStack(RegisterArg edx) :: code, continue) | (CTypeSignedInt, 0w2) => (* Signed 16-bits. *) loadArgs32(args, stackOffset+4, newArgOffset+size, Move{source=MemoryArg baseAddr, destination=RegisterArg edx, moveSize=Move16X32 } :: PushToStack(RegisterArg edx) :: code, continue) | (_, 0w4) => (* 32-bits. *) loadArgs32(args, stackOffset+4, newArgOffset+size, PushToStack(MemoryArg baseAddr) :: code, continue) | (CTypeFloatingPt, 0w8) =>(* Double: push the two words. High-order word first, then low-order. *) loadArgs32(args, stackOffset+8, newArgOffset+size, PushToStack(MemoryArg{base=mlArg2Reg, offset=Word.toInt newArgOffset+4, index=NoIndex}) :: PushToStack(MemoryArg{base=mlArg2Reg, offset=Word.toInt newArgOffset, index=NoIndex}) :: code, continue) | _ => raise Foreign.Foreign "argument type not supported" end val {typeForm, size, ...} = result val resultMemory = {base=ecx, offset=0, index=NoIndex} (* Structures are passed by reference by storing the address of the result as the first argument except that in MS_CDECL (and STDCALL?) structures of size 1, 2, 4 and 8 are returned in EAX, and for 8, EDX. *) val (getResult, needResultAddress) = if (case typeForm of CTypeStruct _ => true | _ => false) andalso (abi = FFI_SYSV orelse (size <> 0w1 andalso size <> 0w2 andalso size <> 0w4 andalso size <> 0w8)) (* TODO: We have to get the address of the destination area. *) then ([], true) else if typeForm = CTypeVoid then ([], false) else (loadMemory(ecx, esp, 4, nativeWordOpSize) :: loadHeapMemory(ecx, ecx, 0, nativeWordOpSize) :: (if size = 0w1 then (* Single byte *) [Move{source=RegisterArg eax, destination=MemoryArg resultMemory, moveSize=Move8}] else if size = 0w2 then (* 16-bits *) [Move{source=RegisterArg eax, destination=MemoryArg resultMemory, moveSize=Move16}] else if typeForm = CTypeFloatingPt andalso size = 0w4 then [FPStoreToMemory{address=resultMemory, precision=SinglePrecision, andPop=true }] else if size = 0w4 then [Move{source=RegisterArg eax, destination=MemoryArg resultMemory, moveSize=Move32}] else if typeForm = CTypeFloatingPt andalso size = 0w8 then [FPStoreToMemory{address=resultMemory, precision=DoublePrecision, andPop=true }] else if size = 0w8 then [ Move{source=RegisterArg eax, destination=MemoryArg resultMemory, moveSize=Move32}, Move{source=RegisterArg edx, destination=MemoryArg {base=ecx, offset=4, index=NoIndex}, moveSize=Move32} ] else raise Foreign.Foreign "Unrecognised result type"), false) local (* Load the arguments. If we need to pass the return address for a struct that is the first arg. *) val (startStack, startCode) = if needResultAddress then (4, [PushToStack(MemoryArg{base=ecx, offset=0, index=NoIndex})]) else (0, []) in val (argCode, argStack) = loadArgs32(args, startStack, 0w0, startCode, fn (stackOffset, _, code) => (code, stackOffset)) end local val align = argStack mod 16 in (* Always align the stack. It's not always necessary on 32-bits but GCC prefers it. *) val preArgAlign = if align = 0 then 0 else 16-align (* Adjustment to be made when the function returns. Stdcall resets the stack in the callee. *) val postCallStackReset = preArgAlign + (if abi = FFI_STDCALL then 0 else argStack) end in ( (* If we're returning a struct we need the result address before we call. *) if needResultAddress then [loadMemory(ecx, esp, 4, nativeWordOpSize)] else [] ) @ [ (* Save the stack pointer. *) storeMemory(esp, ebp, memRegStackPtr, nativeWordOpSize), (* Save ML stack and switch to C stack. *) loadMemory(esp, ebp, memRegCStackPtr, nativeWordOpSize) (* Load the saved C stack pointer. *) ] @ ( if preArgAlign = 0 then [] else [ArithToGenReg{opc=SUB, output=esp, source=NonAddressConstArg(LargeInt.fromInt preArgAlign), opSize=nativeWordOpSize}] ) @ ( (* The second argument is a SysWord containing the address of a malloced area of memory with the actual arguments in it. *) if null args then [] else [loadHeapMemory(mlArg2Reg, mlArg2Reg, 0, nativeWordOpSize)] ) @ argCode @ CallAddress(MemoryArg{base=eax, offset=0, index=NoIndex}) :: (* Restore the C stack. This is really only necessary if we've called a callback since that will store its esp value. *) ( if postCallStackReset = 0 then [] else [ArithToGenReg{opc=ADD, output=esp, source=NonAddressConstArg(LargeInt.fromInt postCallStackReset), opSize=nativeWordOpSize}] ) @ [ storeMemory(esp, ebp, memRegCStackPtr, nativeWordOpSize), loadMemory(esp, ebp, memRegStackPtr, nativeWordOpSize) (* Restore the ML stack pointer. *) ] @ getResult @ (* Store the result in the destination. *) [ ReturnFromFunction 1 ] end fun closure32Bits(abi, args, result) = let (* Arguments are copied from the stack into a struct that is then passed to the ML function. *) fun copyArgs([], nArgs, argOffset, code, continue) = continue(nArgs, argOffset, code) | copyArgs(arg::args, nArgs, argOffset, code, continue) = let val {size, align, typeForm} = arg val newArgOffset = alignUp(argOffset, align) val sourceAddr = {base=ebx, offset=nArgs*4, index=NoIndex} val destAddr = {base=esp, offset=Word.toInt newArgOffset, index=NoIndex} in case (typeForm, size) of (CTypeStruct elements, _) => (* structs passed as values are recursively unpacked. *) copyArgs(elements, nArgs, newArgOffset (* Struct is aligned. *), code, fn (na, ao, c) => copyArgs(args, na, ao, c, continue)) | (CTypeVoid, _) => raise Foreign.Foreign "Void cannot be used for a function argument" | (CTypeFloatingPt, 0w8) => (* Double: copy the two words. High-order word first, then low-order. *) copyArgs(args, nArgs+2, argOffset+size, Move{source=MemoryArg sourceAddr, destination=RegisterArg eax, moveSize=Move32} :: Move{source=RegisterArg eax, destination=MemoryArg destAddr, moveSize=Move32} :: Move{source=MemoryArg {base=ebx, offset=nArgs*4+4, index=NoIndex}, destination=RegisterArg eax, moveSize=Move32} :: Move{source=RegisterArg eax, destination=MemoryArg{base=esp, offset=Word.toInt newArgOffset + 4, index=NoIndex}, moveSize=Move32} :: code, continue) | _ => (* Everything else is a single word on the stack. *) let val moveOp = case size of 0w1 => Move8 | 0w2 => Move16 | 0w4 => Move32 | _ => raise Foreign.Foreign "copyArgs: Invalid size" in copyArgs(args, nArgs+1, argOffset+size, Move{source=MemoryArg sourceAddr, destination=RegisterArg eax, moveSize=Move32} :: Move{source=RegisterArg eax, destination=MemoryArg destAddr, moveSize=moveOp} :: code, continue) end end val {typeForm, size, align, ...} = result (* Struct results are normally passed by reference. *) val resultStructByRef = (case typeForm of CTypeStruct _ => true | _ => false) andalso (abi = FFI_SYSV orelse (size <> 0w1 andalso size <> 0w2 andalso size <> 0w4 andalso size <> 0w8)) val (argCount, argumentSpace, copyArgsFromStack) = copyArgs(args, if resultStructByRef then 1 else 0, 0w0, [], fn result => result) val resultOffset = alignUp(argumentSpace, align) (* Offset of result area *) val (loadResults, resultSize) = if typeForm = CTypeVoid orelse resultStructByRef then ([], 0w0) else let val resultMem = {base=esp, offset=Word.toInt resultOffset, index=NoIndex} val resultCode = case (typeForm, size) of (CTypeSignedInt, 0w1) => [Move{source=MemoryArg resultMem, destination=RegisterArg eax, moveSize=Move8X32 }] | (_, 0w1) => [Move{source=MemoryArg resultMem, destination=RegisterArg eax, moveSize=Move8 }] | (CTypeSignedInt, 0w2) => [Move{source=MemoryArg resultMem, destination=RegisterArg eax, moveSize=Move16X32 }] | (_, 0w2) => [Move{source=MemoryArg resultMem, destination=RegisterArg eax, moveSize=Move16 }] | (CTypeFloatingPt, 0w4) => [FPLoadFromMemory{ address=resultMem, precision=SinglePrecision }] | (_, 0w4) => [Move{source=MemoryArg resultMem, destination=RegisterArg eax, moveSize=Move32 }] | (CTypeFloatingPt, 0w8) => [FPLoadFromMemory{ address=resultMem, precision=DoublePrecision }] | (_, 0w8) => (* MSC only. Struct returned in eax/edx. *) [ Move{source=MemoryArg resultMem, destination=RegisterArg eax, moveSize=Move32 }, Move{source=MemoryArg {base=esp, offset=Word.toInt resultOffset + 4, index=NoIndex}, destination=RegisterArg edx, moveSize=Move32 } ] | _ => raise Foreign.Foreign "Unrecognised result type" in (resultCode, size) end val stackSpace = Word.toInt(resultOffset + resultSize) local val align = stackSpace mod 16 in (* Stack space. In order to align the stack correctly for GCC we need the value in memRegCStackPtr to be a multiple of 16 bytes + 8. esp would have been on a 16 byte boundary before the return address was pushed so after pushing the return address and four registers we need a further 4 bytes to get the alignment back again. The effect of this is that the argument and result area is on an 8-byte boundary. *) val stackToAllocate = stackSpace + (if align = 0 then 0 else 16-align) + 4 end in [ (* Push callee-save registers. *) PushToStack(RegisterArg ebp), PushToStack(RegisterArg ebx), PushToStack(RegisterArg edi), PushToStack(RegisterArg esi), (* Set ebx to point to the original args. *) LoadAddress{ output=ebx, offset=20, base=SOME esp, index=NoIndex, opSize=OpSize32}, (* Allocate stack space. *) ArithToGenReg{opc=SUB, output=esp, source=NonAddressConstArg(LargeInt.fromInt stackToAllocate), opSize=OpSize32}, (* Move the function address in eax into esi since that's a callee-save register. *) Move{source=RegisterArg eax, destination=RegisterArg esi, moveSize=Move32} ] @ copyArgsFromStack @ [ (* Get the value for ebp. *) Move{source=AddressConstArg getThreadDataCall, destination=RegisterArg ecx, moveSize=Move32}, CallAddress(MemoryArg{base=ecx, offset=0, index=NoIndex}), (* Get the address - N.B. Heap addr in 32-in-64. *) moveRR{source=eax, output=ebp, opSize=OpSize32}, (* Save the address of the argument and result area. *) moveRR{source=esp, output=ecx, opSize=OpSize32}, (* Switch to the ML stack. *) storeMemory(esp, ebp, memRegCStackPtr, OpSize32), loadMemory(esp, ebp, memRegStackPtr, OpSize32), (* Move esi into the closure register edx *) Move{source=RegisterArg esi, destination=RegisterArg edx, moveSize=Move32} ] @ boxRegAsSysWord(ecx, eax, []) @ ( (* If we're returning a struct the address for the result will have been passed in the first argument. We use that as the result area. Otherwise point to the result area on the stack. *) if resultStructByRef then Move{source=MemoryArg {offset=0, base=ebx, index=NoIndex}, destination=RegisterArg ecx, moveSize=Move32} else ArithToGenReg{opc=ADD, output=ecx, source=NonAddressConstArg(Word.toLargeInt resultOffset), opSize=OpSize32} ) :: boxRegAsSysWord(ecx, ebx, [eax]) @ [ (* Call the ML function using the full closure call. *) CallAddress(MemoryArg{offset=0, base=edx, index=NoIndex}), (* Save the ML stack pointer because we may have grown the stack. Switch to the C stack. *) storeMemory(esp, ebp, memRegStackPtr, OpSize32), loadMemory(esp, ebp, memRegCStackPtr, OpSize32) ] @ loadResults @ [ (* Remove the stack space. *) ArithToGenReg{opc=ADD, output=esp, source=NonAddressConstArg(LargeInt.fromInt stackToAllocate), opSize=OpSize32}, PopR esi, PopR edi, PopR ebx, PopR ebp (* Restore callee-save registers. *) ] @ ( (* If we've passed in the address of the area for the result structure we're supposed to pass that back in eax. *) if resultStructByRef then [loadMemory(eax, esp, 4, OpSize32)] else [] ) @ [ (* Callee removes arguments in StdCall. *) ReturnFromFunction (if abi = FFI_STDCALL then argCount else 0) ] end local (* Windows on X64. *) val win64ArgRegs = [ (rcx, xmm0), (rdx, xmm1), (r8, xmm2), (r9, xmm3) ] in fun callWindows64Bits(args, result) = let val extraStackReg = r10 (* Not used for any arguments. *) fun loadWin64Args([], stackOffset, _, _, code, extraStack, preCode) = (code, stackOffset, preCode, extraStack) | loadWin64Args(arg::args, stackOffset, argOffset, regs, code, extraStack, preCode) = let val {size, align, typeForm, ...} = arg val newArgOffset = alignUp(argOffset, align) val baseAddr = {base=mlArg2Reg, offset=Word.toInt newArgOffset, index=NoIndex} val workReg = rcx (* rcx: the last to be loaded. *) (* Integer arguments. *) fun loadIntArg moveOp = case regs of (areg, _) :: regs' => loadWin64Args(args, stackOffset, newArgOffset+size, regs', Move{source=MemoryArg baseAddr, destination=RegisterArg areg, moveSize=moveOp } :: code, extraStack, preCode) | [] => loadWin64Args(args, stackOffset+8, newArgOffset+size, [], if size = 0w8 then PushToStack(MemoryArg baseAddr) :: code else (* Need to load it into a register first. *) Move{source=MemoryArg baseAddr, destination=RegisterArg workReg, moveSize=moveOp } :: PushToStack(RegisterArg workReg) :: code, extraStack, preCode) in (* Structs of 1, 2, 4 and 8 bytes are passed as the corresponding int. It may not be necessary to sign-extend 1, 2 or 4-byte values. 2, 4 or 8-byte structs may not be aligned onto the appropriate boundary but it should still work. *) case (size, typeForm) of (0w1, CTypeSignedInt) => (* Signed char. *) loadIntArg Move8X64 | (0w1, _) => (* Unsigned char or single byte struct *) loadIntArg Move8 | (0w2, CTypeSignedInt) =>(* Signed 16-bits. *) loadIntArg Move16X64 | (0w2, _) => (* Unsigned 16-bits. *) loadIntArg Move16 | (0w4, CTypeFloatingPt) => ( case regs of (_, fpReg) :: regs' => loadWin64Args(args, stackOffset, newArgOffset+size, regs', XMMArith{opc=SSE2MoveFloat, source=MemoryArg baseAddr, output=fpReg } :: code, extraStack, preCode) | [] => loadWin64Args(args, stackOffset+8, newArgOffset+size, [], Move{source=MemoryArg baseAddr, destination=RegisterArg workReg, moveSize=Move32 } :: PushToStack(RegisterArg workReg) :: code, extraStack, preCode) ) | (0w4, CTypeSignedInt) => (* Signed 32-bits. *) loadIntArg Move32X64 | (0w4, _) => (* Unsigned 32-bits. *) loadIntArg Move32 | (0w8, CTypeFloatingPt) => ( case regs of (_, fpReg) :: regs' => loadWin64Args(args, stackOffset, newArgOffset+size, regs', XMMArith{opc=SSE2MoveDouble, source=MemoryArg baseAddr, output=fpReg } :: code, extraStack, preCode) | [] => loadWin64Args(args, stackOffset+8, newArgOffset+size, [], Move{source=MemoryArg baseAddr, destination=RegisterArg workReg, moveSize=Move64 } :: PushToStack(RegisterArg workReg) :: code, extraStack, preCode) ) | (0w8, _) => (* 64-bits. *) loadIntArg Move64 | (_, CTypeStruct _) => let (* Structures of other sizes are passed by reference. They are first copied into new areas on the stack. This ensures that the called function can update the structure without changing the original values. *) val newExtra = intAlignUp(extraStack + Word.toInt size, 0w16) val newPreCode = moveMemory{source=(mlArg2Reg, Word.toInt newArgOffset), destination=(extraStackReg, extraStack), length=Word.toInt size} @ preCode in case regs of (areg, _) :: regs' => loadWin64Args(args, stackOffset, newArgOffset+size, regs', loadAddress{source=(extraStackReg, extraStack), destination=areg} :: code, newExtra, newPreCode) | [] => loadWin64Args(args, stackOffset+8, newArgOffset+size, [], loadAddress{source=(extraStackReg, extraStack), destination=workReg} :: PushToStack(RegisterArg workReg) :: code, newExtra, newPreCode) end | _ => raise Foreign.Foreign "Unrecognised type for function argument" end val {typeForm, size, ...} = result val resultAreaPtr = r12 (* Saved value of r8 - This is callee save. *) val resultMemory = {base=resultAreaPtr, offset=0, index=NoIndex} fun storeIntValue moveOp = ([Move{source=RegisterArg eax, destination=MemoryArg resultMemory, moveSize=moveOp}], false) and storeFloatValue precision = ([XMMStoreToMemory{toStore=xmm0, address=resultMemory, precision=precision}], false) val (getResult, passStructAddress) = case (typeForm, size) of (CTypeVoid, _) => ([], false) | (_, 0w1) (* Includes structs *) => (* Single byte *) storeIntValue Move8 | (_, 0w2) => (* 16-bits *) storeIntValue Move16 | (CTypeFloatingPt, 0w4) => storeFloatValue SinglePrecision | (_, 0w4) => storeIntValue Move32 | (CTypeFloatingPt, 0w8) => storeFloatValue DoublePrecision | (_, 0w8) => storeIntValue Move64 | (CTypeStruct _, _) => ([], true) | _ => raise Foreign.Foreign "Unrecognised result type" (* argCode is the code to load and push the arguments. argStack is the amount of stack space the arguments will take. It's only used to ensure that the stack is aligned onto a 16-byte boundary. preArgCode is any code that is needed to copy the arguments before they are actually loaded. Because it is done before the argument registers are loaded it can use rcx, rdi and rsi. extraStack is local stack space needed. It is usually zero but if it is non-zero it must be a multiple of 16 bytes. The address of this area is loaded into r10 before preArgCode is called. *) val (argCode, argStack, preArgCode, extraStack) = if passStructAddress then (* The address of the result structure goes in the first argument register: rcx *) loadWin64Args(args, 0, 0w0, tl win64ArgRegs, [moveRR{source=resultAreaPtr, output=rcx, opSize=nativeWordOpSize}], 0, []) else loadWin64Args(args, 0, 0w0, win64ArgRegs, [], 0, []) local val align = argStack mod 16 in (* Always align the stack. *) val preArgAlign = if align = 0 then 0 else 16-align (* The total space on the stack that needs to be removed at the end. *) val postCallStackReset = argStack + preArgAlign + extraStack + 32 end in (* Save heap ptr. Needed in case we have a callback. *) [storeMemory(r15, ebp, memRegLocalMPointer, nativeWordOpSize)] @ ( (* Put the destination address into a callee save resgister. We have to put the C address in there now because an ML address wouldn't be updated by a possible GC in a callback. *) if #typeForm( result) <> CTypeVoid then [loadHeapMemory(resultAreaPtr, r8, 0, nativeWordOpSize)] else [] ) @ [ (* Save the stack pointer. *) storeMemory(esp, ebp, memRegStackPtr, nativeWordOpSize), (* Save ML stack and switch to C stack. *) loadMemory(esp, ebp, memRegCStackPtr, nativeWordOpSize) (* Load the saved C stack pointer. *) ] @ ( if extraStack = 0 then [] else [ ArithToGenReg{opc=SUB, output=rsp, source=NonAddressConstArg(LargeInt.fromInt extraStack), opSize=nativeWordOpSize}, Move{source=RegisterArg rsp, destination=RegisterArg extraStackReg, moveSize=Move64} ] ) @ ( if preArgAlign = 0 then [] else [ArithToGenReg{opc=SUB, output=esp, source=NonAddressConstArg(LargeInt.fromInt preArgAlign), opSize=nativeWordOpSize}] ) @ ( (* The second argument is a SysWord containing the address of a malloced area of memory with the actual arguments in it. *) if null args then [] else [loadHeapMemory(mlArg2Reg, mlArg2Reg, 0, nativeWordOpSize)] ) @ preArgCode @ argCode @ [ (* Reserve a 32-byte area after the arguments. This is specific to the Windows ABI. *) ArithToGenReg{opc=SUB, output=esp, source=NonAddressConstArg(LargeInt.fromInt 32), opSize=nativeWordOpSize}, let (* The entry point is in a SysWord.word value in RAX. *) val entryPoint = case targetArch of ObjectId32Bit => MemoryArg{base=ebx, offset=0, index=Index4 eax} | _ => MemoryArg{base=eax, offset=0, index=NoIndex} in (* Call the function. We're discarding the value in rsp so no need to remove args. *) CallAddress entryPoint end, (* Restore the C stack value in case it's been changed by a callback. *) ArithToGenReg{opc=ADD, output=rsp, source=NonAddressConstArg(LargeInt.fromInt postCallStackReset), opSize=nativeWordOpSize}, storeMemory(rsp, rbp, memRegCStackPtr, nativeWordOpSize), loadMemory(rsp, rbp, memRegStackPtr, nativeWordOpSize), (* Restore the ML stack pointer. *) (* Reload the heap pointer. If we've called back to ML this could well have changed. *) loadMemory(r15, rbp, memRegLocalMPointer, nativeWordOpSize) ] @ (* Store the result in the destination. *) getResult @ [ReturnFromFunction 0 ] end (* callWindows64Bits *) fun closureWindows64Bits(args, result) = let val {typeForm, size, align, ...} = result (* Struct results are normally passed by reference. *) val resultStructByRef = (* If true we've copied rcx (the first arg) into r9 *) (case typeForm of CTypeStruct _ => true | _ => false) andalso size <> 0w1 andalso size <> 0w2 andalso size <> 0w4 andalso size <> 0w8 (* Store the register arguments and copy everything else into the argument structure on the stack. The code is ordered so that the early arguments are stored first. *) fun copyWin64Args([], _, _, _) = [] | copyWin64Args(arg::args, nStackArgs, argOffset, regs) = let val {size, align, typeForm, ...} = arg val newArgOffset = alignUp(argOffset, align) val destAddr = {base=rsp, offset=Word.toInt newArgOffset, index=NoIndex} (* Integer arguments. *) fun moveIntArg moveOp = case regs of (areg, _) :: regs' => Move{source=RegisterArg areg, destination=MemoryArg destAddr, moveSize=moveOp } :: copyWin64Args(args, nStackArgs, newArgOffset+size, regs') | [] => Move{source=MemoryArg {base=r10, offset=nStackArgs*8, index=NoIndex}, destination=RegisterArg rax, moveSize=Move64} :: Move{source=RegisterArg rax, destination=MemoryArg destAddr, moveSize=moveOp} :: copyWin64Args(args, nStackArgs+1, newArgOffset+size, []) in (* Structs of 1, 2, 4 and 8 bytes are passed as the corresponding int. *) case (typeForm, size) of (_, 0w1) => moveIntArg Move8 | (_, 0w2) => moveIntArg Move16 | (CTypeFloatingPt, 0w4) => ( case regs of (_, fpReg) :: regs' => XMMStoreToMemory{ toStore=fpReg, address=destAddr, precision=SinglePrecision} :: copyWin64Args(args, nStackArgs, newArgOffset+size, regs') | [] => moveIntArg Move32 ) | (_, 0w4) => (* 32-bits *) moveIntArg Move32 | (CTypeFloatingPt, 0w8) => ( case regs of (_, fpReg) :: regs' => XMMStoreToMemory{ toStore=fpReg, address=destAddr, precision=DoublePrecision} :: copyWin64Args(args, nStackArgs, newArgOffset+size, regs') | [] => moveIntArg Move64 ) | (_, 0w8) => (* 64-bits. *) moveIntArg Move64 | (CTypeStruct _, _) => (* Structures of other size are passed by reference. We need to copy the source structure into our stack area. Since rsi and rdi aren't used as args and rcx is only used for the first argument we can copy the argument now. *) ( case regs of (arg, _) :: regs' => moveMemory{source=(arg, 0), destination=(rsp, Word.toInt newArgOffset), length=Word.toInt size} @ copyWin64Args(args, nStackArgs, newArgOffset+size, regs') | [] => moveMemory{source=(r10, nStackArgs*8), destination=(rsp, Word.toInt newArgOffset), length=Word.toInt size} @ copyWin64Args(args, nStackArgs+1, newArgOffset+size, []) ) | _ => raise Foreign.Foreign "Unrecognised type for function argument" end val copyArgsFromRegsAndStack = if resultStructByRef then (* If we're returning a struct by reference we copy the address into r9 and pass that as the result address. *) Move{source=RegisterArg rcx, destination=RegisterArg r9, moveSize=Move64} :: copyWin64Args(args, 0, 0w0, tl win64ArgRegs) else copyWin64Args(args, 0, 0w0, win64ArgRegs) local fun getNextSize (arg, argOffset) = let val {size, align, ...} = arg in alignUp(argOffset, align) + size end in val argumentSpace = List.foldl getNextSize 0w0 args end val resultOffset = alignUp(argumentSpace, align) (* Offset of result area *) val (loadResults, resultSize) = if typeForm = CTypeVoid orelse resultStructByRef then ([], 0w0) else let val resultMem = {base=rsp, offset=Word.toInt resultOffset, index=NoIndex} val resultCode = case (typeForm, size) of (CTypeSignedInt, 0w1) => [Move{source=MemoryArg resultMem, destination=RegisterArg rax, moveSize=Move8X64}] | (_, 0w1) => [Move{source=MemoryArg resultMem, destination=RegisterArg rax, moveSize=Move8}] | (CTypeSignedInt, 0w2) => [Move{source=MemoryArg resultMem, destination=RegisterArg rax, moveSize=Move16X64}] | (_, 0w2) => [Move{source=MemoryArg resultMem, destination=RegisterArg rax, moveSize=Move16}] | (CTypeFloatingPt, 0w4) => [XMMArith{opc=SSE2MoveFloat, source=MemoryArg resultMem, output=xmm0}] | (CTypeSignedInt, 0w4) => [Move{source=MemoryArg resultMem, destination=RegisterArg rax, moveSize=Move32X64}] | (_, 0w4) => [Move{source=MemoryArg resultMem, destination=RegisterArg rax, moveSize=Move32}] | (CTypeFloatingPt, 0w8) => [XMMArith{opc=SSE2MoveDouble, source=MemoryArg resultMem, output=xmm0}] | (_, 0w8) => [Move{source=MemoryArg resultMem, destination=RegisterArg rax, moveSize=Move64}] | _ => raise Foreign.Foreign "Unrecognised result type" in (resultCode, size) end (* Stack space. The stack must be 16 byte aligned. We've pushed 8 regs and a return address so add a further 8 bytes to bring it back into alignment. If we're returning a struct by reference, though, we've pushed 9 regs so don't add 8. *) val stackToAllocate = Word.toInt(alignUp(resultOffset + resultSize, 0w16)) + (if resultStructByRef then 0 else 8) in [ (* Push callee-save registers. *) PushToStack(RegisterArg rbp), PushToStack(RegisterArg rbx), PushToStack(RegisterArg r12), PushToStack(RegisterArg r13), PushToStack(RegisterArg r14), PushToStack(RegisterArg r15), PushToStack(RegisterArg rdi), PushToStack(RegisterArg rsi) ] @ ( (* If we're returning a struct by reference we have to return the address in rax even though it's been set by the caller. Save this address. *) if resultStructByRef then [PushToStack(RegisterArg rcx)] else [] ) @ [ (* Set r10 to point to the original stack args if any. This is beyond the pushed regs and also the 32-byte area. *) LoadAddress{ output=r10, offset=if resultStructByRef then 112 else 104, base=SOME rsp, index=NoIndex, opSize=nativeWordOpSize}, (* Allocate stack space. *) ArithToGenReg{opc=SUB, output=rsp, source=NonAddressConstArg(LargeInt.fromInt stackToAllocate), opSize=nativeWordOpSize}, (* Move the function we're calling, in rax, into r13, a callee-save register *) moveRR{source=rax, output=r13, opSize=polyWordOpSize} ] @ copyArgsFromRegsAndStack @ [ (* Get the value for rbp. *) (* This is a problem for 32-in-64. The value of getThreadDataCall is an object ID but rbx may well no longer hold the heap base address. We use a special inline constant to hold the full 64-bit address. *) LoadAbsolute{value=getThreadDataCall, destination=rcx}, CallAddress(MemoryArg{base=rcx, offset=0, index=NoIndex}), moveRR{source=rax, output=rbp, opSize=nativeWordOpSize}, (* Save the address of the argument and result area. *) moveRR{source=rsp, output=rcx, opSize=nativeWordOpSize}, (* Switch to the ML stack. *) storeMemory(rsp, rbp, memRegCStackPtr, nativeWordOpSize), loadMemory(rsp, rbp, memRegStackPtr, nativeWordOpSize), (* Load the ML heap pointer. *) loadMemory(r15, rbp, memRegLocalMPointer, nativeWordOpSize), (* Now move the function closure into the closure register ready for the call. *) moveRR{source=r13, output=rdx, opSize=polyWordOpSize} ] @ (* Reload the heap base address in 32-in-64. *) ( if targetArch = ObjectId32Bit then [loadMemory(rbx, rbp, memRegSavedRbx, nativeWordOpSize)] else [] ) @ boxRegAsSysWord(rcx, rax, []) @ ( (* If we're returning a struct by reference the address for the result will have been passed in the first argument. We use that as the result area. Otherwise point to the result area on the stack. *) if resultStructByRef then loadMemory(rcx, r10, ~112, nativeWordOpSize) else ArithToGenReg{opc=ADD, output=rcx, source=NonAddressConstArg(Word.toLargeInt resultOffset), opSize=nativeWordOpSize} ) :: boxRegAsSysWord(rcx, mlArg2Reg, [rax]) @ [ (* Call the ML function using the full closure call. *) CallAddress( if targetArch = ObjectId32Bit then MemoryArg{base=rbx, index=Index4 rdx, offset=0} else MemoryArg{base=rdx, index=NoIndex, offset=0}), (* Save the ML stack pointer because we may have grown the stack. Switch to the C stack. *) storeMemory(rsp, rbp, memRegStackPtr, nativeWordOpSize), loadMemory(rsp, rbp, memRegCStackPtr, nativeWordOpSize), storeMemory(r15, rbp, memRegLocalMPointer, nativeWordOpSize) ] @ loadResults @ [ (* Remove the stack space. *) ArithToGenReg{opc=ADD, output=rsp, source=NonAddressConstArg(LargeInt.fromInt stackToAllocate), opSize=nativeWordOpSize} ] @ ( if resultStructByRef then [PopR rax] else [] ) @ [ PopR rsi, PopR rdi, PopR r15, PopR r14, PopR r13, PopR r12, PopR rbx, PopR rbp, (* Restore callee-save registers. *) ReturnFromFunction 0 (* Caller removes any stack arguments. *) ] end end local (* The rules for passing structs in SysV on X86/64 are complicated but most of the special cases don't apply. We don't support floating point larger than 8 bytes, packed structures or C++ constructors. It then reduces to the following: Structures of up to 8 bytes are passed in a single register and of 8-16 bytes in two registers. Larger structures are passed on the stack. The question is whether to use general registers or SSE2 registers. Each 8 byte chunk is considered independently after any internal structs have been unwrapped. Each chunk will consist of either a single 8-byte value (i.e.. a pointer, int64_t or a double) or one or more smaller values and possibly some padding. An SSE2 register is used if the value is a double, two floats or a single float and padding. Otherwise it must have at least one shorter int-like type (e.g. int, char, short etc) in which case a general register is used. That applies even if it also contains a float. If, having selected the kind of registers to be used, there are not enough for the whole struct it is passed on the stack. We don't really need this for simple arguments but it's easier to consider them all together. *) datatype argClass = ArgInMemory | ArgInRegs of { firstInSSE: bool, secondInSSE: bool } fun classifyArg arg = let val {size, ...} = arg (* Unwrap the struct and any internal structs. *) fun getFields([], _) = [] | getFields(field::fields, offset) = let val {size, align, typeForm} = field val alignedOffset = alignUp(offset, align) (* Align this even if it's a sub-struct *) in case typeForm of CTypeVoid => raise Foreign.Foreign "Void cannot be used for a function argument" | CTypeStruct elements => getFields(elements, alignedOffset) @ getFields(fields, alignedOffset+size) | _ => (typeForm, alignedOffset) :: getFields(fields, alignedOffset+size) end val isSSE = List.all (fn (CTypeFloatingPt, _) => true | _ => false) in if size > 0w16 then ArgInMemory else let val fieldsAndOffsets = getFields([arg], 0w0) in if size <= 0w8 (* Only the first register will be used. *) then ArgInRegs{firstInSSE=isSSE fieldsAndOffsets, secondInSSE=false} else let val (first8Bytes, second8Bytes) = List.partition (fn (_, off) => off <= 0w8) fieldsAndOffsets in ArgInRegs{firstInSSE=isSSE first8Bytes, secondInSSE=isSSE second8Bytes} end end end val sysVGenRegs = [rdi, rsi, rdx, rcx, r8, r9] and sysVFPRegs = [xmm0, xmm1, xmm2, xmm3, xmm4, xmm5, xmm6, xmm7] (* Store a register into upto 8 bytes. Most values will involve a single store but odd-sized structs can require shifts and multiple stores. N.B. May modify the source register. *) fun storeUpTo8(reg, base, offset, size) = let val moveOp = if size = 0w8 then Move64 else if size >= 0w4 then Move32 else if size >= 0w2 then Move16 else Move8 in [Move{source=RegisterArg reg, destination=MemoryArg {base=base, offset=offset, index=NoIndex}, moveSize=moveOp}] end @ ( if size = 0w6 orelse size = 0w7 then [ ShiftConstant{ shiftType=SHR, output=reg, shift=0w32, opSize=OpSize64 }, Move{source=RegisterArg reg, destination=MemoryArg {base=base, offset=offset+4, index=NoIndex}, moveSize=Move16} ] else [] ) @ ( if size = 0w3 orelse size = 0w5 orelse size = 0w7 then [ ShiftConstant{ shiftType=SHR, output=reg, shift=Word8.fromLargeWord(Word.toLargeWord((size-0w1)*0w8)), opSize=OpSize64 }, Move{source=RegisterArg reg, destination=MemoryArg {base=base, offset=offset+Word.toInt(size-0w1), index=NoIndex}, moveSize=Move8} ] else [] ) in fun callUnix64Bits(args, result) = let val argWorkReg = r10 (* Not used for any arguments. *) val resultAreaPtr = r12 (* Saved value of r8 - This is callee save. *) val argPtrReg = r11 (* Pointer to argument area - Can't use mlArg2Reg since that's RSI on 32-in-64. *) fun loadSysV64Args([], stackOffset, _, _, _, code, preCode) = (code, stackOffset, preCode) | loadSysV64Args(arg::args, stackOffset, argOffset, gRegs, fpRegs, code, preCode) = let val {size, align, typeForm, ...} = arg (* Load a value into a register. Normally the size will be 1, 2, 4 or 8 bytes and this will just involve a simple load. Structs, though, can be of any size up to 8 bytes. *) fun loadRegister(reg, offset, size) = let (* We don't necessarily have to sign-extend. There's a comment in libffi that suggests that LVM expects it even though the SysV ABI doesn't require it. *) val moveOp = if size = 0w8 then Move64 else if typeForm = CTypeSignedInt andalso size = 0w4 then Move32X64 else if size >= 0w4 then Move32 else if typeForm = CTypeSignedInt andalso size = 0w2 then Move16X64 else if size >= 0w2 then Move16 else if typeForm = CTypeSignedInt andalso size = 0w1 then Move8X64 else Move8 in [Move{source=MemoryArg{base=argPtrReg, offset=Word.toInt offset, index=NoIndex}, destination=RegisterArg reg, moveSize=moveOp}] end @ ( if size = 0w6 orelse size = 0w7 then [ Move{source=MemoryArg{base=argPtrReg, offset=Word.toInt offset + 4, index=NoIndex}, destination=RegisterArg argWorkReg, moveSize=Move16}, ShiftConstant{ shiftType=SHL, output=argWorkReg, shift=0w32, opSize=OpSize64 }, ArithToGenReg{ opc=OR, output=reg, source=RegisterArg argWorkReg, opSize=OpSize64 } ] else [] ) @ ( if size = 0w3 orelse size = 0w5 orelse size = 0w7 then [ Move{source=MemoryArg{base=argPtrReg, offset=Word.toInt offset + Word.toInt(size-0w1), index=NoIndex}, destination=RegisterArg argWorkReg, moveSize=Move8}, ShiftConstant{ shiftType=SHL, output=argWorkReg, shift=Word8.fromLargeWord(Word.toLargeWord((size-0w1)*0w8)), opSize=OpSize64 }, ArithToGenReg{ opc=OR, output=reg, source=RegisterArg argWorkReg, opSize=OpSize64 } ] else [] ) val newArgOffset = alignUp(argOffset, align) val word1Addr = {base=argPtrReg, offset=Word.toInt newArgOffset, index=NoIndex} val word2Addr = {base=argPtrReg, offset=Word.toInt newArgOffset + 8, index=NoIndex} in case (classifyArg arg, size > 0w8, gRegs, fpRegs) of (* 8 bytes or smaller - single general reg. This is the usual case. *) (ArgInRegs{firstInSSE=false, ...}, false, gReg :: gRegs', fpRegs') => loadSysV64Args(args, stackOffset, newArgOffset+size, gRegs', fpRegs', loadRegister(gReg, newArgOffset, size) @ code, preCode) (* 8 bytes or smaller - single SSE reg. Usual case for real arguments. *) | (ArgInRegs{firstInSSE=true, ...}, false, gRegs', fpReg :: fpRegs') => loadSysV64Args(args, stackOffset, newArgOffset+size, gRegs', fpRegs', XMMArith{opc=if size = 0w4 then SSE2MoveFloat else SSE2MoveDouble, source=MemoryArg word1Addr, output=fpReg } :: code, preCode) (* 9-16 bytes - both values in general regs. *) | (ArgInRegs{firstInSSE=false, secondInSSE=false}, true, gReg1 :: gReg2 :: gRegs', fpRegs') => loadSysV64Args(args, stackOffset, newArgOffset+size, gRegs', fpRegs', Move{source=MemoryArg word1Addr, destination=RegisterArg gReg1, moveSize=Move64} :: loadRegister(gReg2, newArgOffset+0w8, size-0w8) @ code, preCode) (* 9-16 bytes - first in general, second in SSE. *) | (ArgInRegs{firstInSSE=false, secondInSSE=true}, true, gReg :: gRegs', fpReg :: fpRegs') => loadSysV64Args(args, stackOffset, newArgOffset+size, gRegs', fpRegs', Move{source=MemoryArg word1Addr, destination=RegisterArg gReg, moveSize=Move64} :: XMMArith{opc=if size = 0w12 then SSE2MoveFloat else SSE2MoveDouble, source=MemoryArg word2Addr, output=fpReg } :: code, preCode) (* 9-16 bytes - first in SSE, second in general. *) | (ArgInRegs{firstInSSE=true, secondInSSE=false}, true, gReg :: gRegs', fpReg :: fpRegs') => loadSysV64Args(args, stackOffset, newArgOffset+size, gRegs', fpRegs', XMMArith{opc=SSE2MoveDouble, source=MemoryArg word1Addr, output=fpReg } :: loadRegister(gReg, newArgOffset+0w8, size-0w8) @ code, preCode) | (* 9-16 bytes - both values in SSE regs. *) (ArgInRegs{firstInSSE=true, secondInSSE=true}, true, gRegs', fpReg1 :: fpReg2 :: fpRegs') => loadSysV64Args(args, stackOffset, newArgOffset+size, gRegs', fpRegs', XMMArith{opc=SSE2MoveDouble, source=MemoryArg word1Addr, output=fpReg1 } :: XMMArith{opc=if size = 0w12 then SSE2MoveFloat else SSE2MoveDouble, source=MemoryArg word2Addr, output=fpReg2 } :: code, preCode) | (_, _, gRegs', fpRegs') => (* Either larger than 16 bytes or we've run out of the right kind of registers. *) (* Move the argument in the preCode. It's possible a large struct could be the first argument and if we left it until the end RDI and RSI would already have been loaded. Structs are passed by value on the stack not, as in Win64, by reference. *) let val space = intAlignUp(Word.toInt size, 0w8) in loadSysV64Args(args, stackOffset+space, newArgOffset+size, gRegs', fpRegs', code, ArithToGenReg{opc=SUB, output=rsp, source=NonAddressConstArg(LargeInt.fromInt space), opSize=nativeWordOpSize} :: moveMemory{source=(argPtrReg, Word.toInt newArgOffset), destination=(rsp, 0), length=Word.toInt size} @ preCode) end end (* The rules for returning structs are similar to those for parameters. *) local (* Store a result register into the result area. In almost all cases this is very simple: the only complication is with structs of odd sizes. *) fun storeResult(reg, offset, size) = storeUpTo8(reg, resultAreaPtr, offset, size) val {size, typeForm, ...} = result in val (getResult, passArgAddress) = if typeForm = CTypeVoid then ([], false) else case (classifyArg result, size > 0w8) of (* 8 bytes or smaller - returned in RAX - Normal case for int-like results. *) (ArgInRegs{firstInSSE=false, ...}, false) => (storeResult(rax, 0, size), false) (* 8 bytes or smaller - returned in XMM0 - Normal case for real results. *) | (ArgInRegs{firstInSSE=true, ...}, false) => ([XMMStoreToMemory{toStore=xmm0, address={base=resultAreaPtr, offset=0, index=NoIndex}, precision=if size = 0w4 then SinglePrecision else DoublePrecision}], false) (* 9-16 bytes - returned in RAX/RDX. *) | (ArgInRegs{firstInSSE=false, secondInSSE=false}, true) => (storeResult(rax, 0, 0w8) @ storeResult(rdx, 0, size-0w8), false) (* 9-16 bytes - first in RAX, second in XMM0. *) | (ArgInRegs{firstInSSE=false, secondInSSE=true}, true) => (XMMStoreToMemory{toStore=xmm0, address={base=resultAreaPtr, offset=8, index=NoIndex}, precision=if size = 0w12 then SinglePrecision else DoublePrecision} :: storeResult(rax, 0, 0w8), false) (* 9-16 bytes - first in XMM0, second in RAX. *) | (ArgInRegs{firstInSSE=true, secondInSSE=false}, true) => (XMMStoreToMemory{toStore=xmm0, address={base=resultAreaPtr, offset=0, index=NoIndex}, precision=DoublePrecision} :: storeResult(rax, 8, size-0w8), false) (* 9-16 bytes - both values in SSE regs.*) | (ArgInRegs{firstInSSE=true, secondInSSE=true}, true) => ([XMMStoreToMemory{toStore=xmm0, address={base=resultAreaPtr, offset=0, index=NoIndex}, precision=DoublePrecision}, XMMStoreToMemory{toStore=xmm1, address={base=resultAreaPtr, offset=8, index=NoIndex}, precision=if size = 0w12 then SinglePrecision else DoublePrecision}], false) | _ => ([], true) (* Have to pass the address of the area in memory *) end val (argCode, argStack, preArgCode) = if passArgAddress (* If we have to pass the address of the result struct it goes in rdi. *) then loadSysV64Args(args, 0, 0w0, tl sysVGenRegs, sysVFPRegs, [moveRR{source=resultAreaPtr, output=rdi, opSize=nativeWordOpSize}], []) else loadSysV64Args(args, 0, 0w0, sysVGenRegs, sysVFPRegs, [], []) local val align = argStack mod 16 in (* Always align the stack. *) val preArgAlign = if align = 0 then 0 else 16-align end in (* Save heap ptr. Needed in case we have a callback. *) [storeMemory(r15, ebp, memRegLocalMPointer, nativeWordOpSize)] @ ( (* Put the destination address into a callee save resgister. We have to put the C address in there now because an ML address wouldn't be updated by a possible GC in a callback. *) if #typeForm( result) <> CTypeVoid then [loadHeapMemory(resultAreaPtr, r8, 0, nativeWordOpSize)] else [] ) @ [ (* Save the stack pointer. *) storeMemory(esp, ebp, memRegStackPtr, nativeWordOpSize), (* Save ML stack and switch to C stack. *) loadMemory(esp, ebp, memRegCStackPtr, nativeWordOpSize) (* Load the saved C stack pointer. *) ] @ ( if preArgAlign = 0 then [] else [ArithToGenReg{opc=SUB, output=esp, source=NonAddressConstArg(LargeInt.fromInt preArgAlign), opSize=nativeWordOpSize}] ) @ ( (* The second argument is a SysWord containing the address of a malloced area of memory with the actual arguments in it. *) if null args then [] else [loadHeapMemory(argPtrReg, mlArg2Reg, 0, nativeWordOpSize)] ) @ preArgCode @ argCode @ [ let (* The entry point is in a SysWord.word value in RAX. *) val entryPoint = case targetArch of ObjectId32Bit => MemoryArg{base=ebx, offset=0, index=Index4 eax} | _ => MemoryArg{base=eax, offset=0, index=NoIndex} in (* Call the function. We're discarding the value in rsp so no need to remove args. *) CallAddress entryPoint end, loadMemory(esp, ebp, memRegStackPtr, nativeWordOpSize), (* Restore the ML stack pointer. *) (* Reload the heap pointer. If we've called back to ML this could well have changed. *) loadMemory(r15, ebp, memRegLocalMPointer, nativeWordOpSize) ] @ (* Store the result in the destination. *) getResult @ [ ReturnFromFunction 0 ] end (* callUnix64Bits *) fun closureUnix64Bits(args, result) = let fun moveSysV64Args([], _, _, _, _, moveFromStack) = moveFromStack | moveSysV64Args(arg::args, stackSpace, argOffset, gRegs, fpRegs, moveFromStack) = let val {size, align, ...} = arg fun storeRegister(reg, offset, size) = storeUpTo8(reg, rsp, offset, size) val newArgOffset = alignUp(argOffset, align) val word1Addr = {base=rsp, offset=Word.toInt newArgOffset, index=NoIndex} val word2Addr = {base=rsp, offset=Word.toInt newArgOffset + 8, index=NoIndex} in case (classifyArg arg, size > 0w8, gRegs, fpRegs) of (* 8 bytes or smaller - single general reg. This is the usual case. *) (ArgInRegs{firstInSSE=false, ...}, false, gReg :: gRegs', fpRegs') => storeRegister(gReg, Word.toInt newArgOffset, size) @ moveSysV64Args(args, stackSpace, newArgOffset+size, gRegs', fpRegs', moveFromStack) (* 8 bytes or smaller - single SSE reg. Usual case for real arguments. *) | (ArgInRegs{firstInSSE=true, ...}, false, gRegs', fpReg :: fpRegs') => XMMStoreToMemory{precision=if size = 0w4 then SinglePrecision else DoublePrecision, address=word1Addr, toStore=fpReg } :: moveSysV64Args(args, stackSpace, newArgOffset+size, gRegs', fpRegs', moveFromStack) (* 9-16 bytes - both values in general regs. *) | (ArgInRegs{firstInSSE=false, secondInSSE=false}, true, gReg1 :: gReg2 :: gRegs', fpRegs') => Move{source=MemoryArg word1Addr, destination=RegisterArg gReg1, moveSize=Move64} :: storeRegister(gReg2, Word.toInt newArgOffset+8, size-0w8) @ moveSysV64Args(args, stackSpace, newArgOffset+size, gRegs', fpRegs', moveFromStack) (* 9-16 bytes - first in general, second in SSE. *) | (ArgInRegs{firstInSSE=false, secondInSSE=true}, true, gReg :: gRegs', fpReg :: fpRegs') => Move{source=MemoryArg word1Addr, destination=RegisterArg gReg, moveSize=Move64} :: XMMStoreToMemory{precision=if size = 0w12 then SinglePrecision else DoublePrecision, address=word2Addr, toStore=fpReg } :: moveSysV64Args(args, stackSpace, newArgOffset+size, gRegs', fpRegs', moveFromStack) (* 9-16 bytes - first in SSE, second in general. *) | (ArgInRegs{firstInSSE=true, secondInSSE=false}, true, gReg :: gRegs', fpReg :: fpRegs') => XMMStoreToMemory{precision=DoublePrecision, address=word1Addr, toStore=fpReg } :: storeRegister(gReg, Word.toInt newArgOffset+8, size-0w8) @ moveSysV64Args(args, stackSpace, newArgOffset+size, gRegs', fpRegs', moveFromStack) | (* 9-16 bytes - both values in SSE regs. *) (ArgInRegs{firstInSSE=true, secondInSSE=true}, true, gRegs', fpReg1 :: fpReg2 :: fpRegs') => XMMStoreToMemory{precision=DoublePrecision, address=word1Addr, toStore=fpReg1 } :: XMMStoreToMemory{precision=if size = 0w12 then SinglePrecision else DoublePrecision, address=word2Addr, toStore=fpReg2 } :: moveSysV64Args(args, stackSpace, newArgOffset+size, gRegs', fpRegs', moveFromStack) | (_, _, gRegs', fpRegs') => (* Either larger than 16 bytes or we've run out of the right kind of register. Structs larger than 16 bytes are passed by value on the stack. Move the argument after we've stored all the registers in particular rsi and rdi. *) let val space = intAlignUp(Word.toInt size, 0w8) in moveSysV64Args(args, stackSpace+space, newArgOffset+size, gRegs', fpRegs', moveMemory{source=(r10, stackSpace), destination=(rsp, Word.toInt newArgOffset), length=Word.toInt size} @ moveFromStack) end end (* Result structs larger than 16 bytes are returned by reference. *) val resultStructByRef = #size ( result) > 0w16 val copyArgsFromRegsAndStack = if resultStructByRef (* rdi contains the address for the result. *) then moveSysV64Args(args, 0, 0w0, tl sysVGenRegs, sysVFPRegs, []) else moveSysV64Args(args, 0, 0w0, sysVGenRegs, sysVFPRegs, []) local fun getNextSize (arg, argOffset) = let val {size, align, ...} = arg in alignUp(argOffset, align) + size end in val argumentSpace = List.foldl getNextSize 0w0 args end (* Allocate a 16-byte area for any results returned in registers. This will not be used if the result is a structure larger than 16-bytes. *) val resultOffset = alignUp(argumentSpace, 0w8) (* Ensure the stack is 16 bytes aligned. We've pushed 6 regs and a return address so add a further 8 bytes to bring it back into alignment. If we're returning a struct by reference, though, we've pushed 7 regs so don't add 8. *) val stackToAllocate = Word.toInt(alignUp(resultOffset + 0w16, 0w16)) + (if resultStructByRef then 0 else 8) (* The rules for returning structs are similar to those for parameters. *) local (* The result area is always 16 bytes wide so we can load the result without risking reading outside. At least at the moment we ignore any sign extension. *) val {size, typeForm, ...} = result val resultOffset = Word.toInt resultOffset in val loadResults = if typeForm = CTypeVoid then [] else case (classifyArg result, size > 0w8) of (* 8 bytes or smaller - returned in RAX - Normal case for int-like results. *) (ArgInRegs{firstInSSE=false, ...}, false) => [Move{source=MemoryArg {base=rsp, offset=resultOffset, index=NoIndex}, destination=RegisterArg rax, moveSize=Move64}] (* 8 bytes or smaller - returned in XMM0 - Normal case for real results. *) | (ArgInRegs{firstInSSE=true, ...}, false) => [XMMStoreToMemory{toStore=xmm0, address={base=rsp, offset=resultOffset, index=NoIndex}, precision=if size = 0w4 then SinglePrecision else DoublePrecision}] (* 9-16 bytes - returned in RAX/RDX. *) | (ArgInRegs{firstInSSE=false, secondInSSE=false}, true) => [Move{source=MemoryArg {base=rsp, offset=resultOffset, index=NoIndex}, destination=RegisterArg rax, moveSize=Move64}, Move{source=MemoryArg {base=rsp, offset=resultOffset+8, index=NoIndex}, destination=RegisterArg rdx, moveSize=Move64}] (* 9-16 bytes - first in RAX, second in XMM0. *) | (ArgInRegs{firstInSSE=false, secondInSSE=true}, true) => [Move{source=MemoryArg {base=rsp, offset=resultOffset, index=NoIndex}, destination=RegisterArg rax, moveSize=Move64}, XMMStoreToMemory{toStore=xmm0, address={base=rsp, offset=resultOffset+8, index=NoIndex}, precision=if size = 0w12 then SinglePrecision else DoublePrecision}] (* 9-16 bytes - first in XMM0, second in RAX. *) | (ArgInRegs{firstInSSE=true, secondInSSE=false}, true) => [XMMStoreToMemory{toStore=xmm0, address={base=rsp, offset=resultOffset, index=NoIndex}, precision=DoublePrecision}, Move{source=MemoryArg {base=rsp, offset=resultOffset+8, index=NoIndex}, destination=RegisterArg rax, moveSize=Move64}] (* 9-16 bytes - both values in SSE regs.*) | (ArgInRegs{firstInSSE=true, secondInSSE=true}, true) => [XMMStoreToMemory{toStore=xmm0, address={base=rsp, offset=resultOffset, index=NoIndex}, precision=DoublePrecision}, XMMStoreToMemory{toStore=xmm1, address={base=rsp, offset=resultOffset+8, index=NoIndex}, precision=if size = 0w12 then SinglePrecision else DoublePrecision}] | _ => [] (* Have to pass the address of the area in memory *) end in [ (* Push callee-save registers. *) PushToStack(RegisterArg rbp), PushToStack(RegisterArg rbx), PushToStack(RegisterArg r12), PushToStack(RegisterArg r13), PushToStack(RegisterArg r14), PushToStack(RegisterArg r15) ] @ ( (* If we're returning a struct by reference we have to return the address in rax even though it's been set by the caller. Save this address. *) if resultStructByRef then [PushToStack(RegisterArg rdi)] else [] ) @ [ (* Set r10 to point to the original stack args if any. *) LoadAddress{ output=r10, offset=if resultStructByRef then 64 else 56, base=SOME rsp, index=NoIndex, opSize=nativeWordOpSize}, (* Allocate stack space. *) ArithToGenReg{opc=SUB, output=rsp, source=NonAddressConstArg(LargeInt.fromInt stackToAllocate), opSize=nativeWordOpSize}, (* Move the function we're calling, in rax, into r13, a callee-save register *) moveRR{source=rax, output=r13, opSize=polyWordOpSize} ] @ copyArgsFromRegsAndStack @ [ (* Get the value for rbp. This has to be an absolute address in 32-in-64. *) LoadAbsolute{value=getThreadDataCall, destination=rcx}, CallAddress(MemoryArg{base=rcx, offset=0, index=NoIndex}), moveRR{source=rax, output=rbp, opSize=nativeWordOpSize}, (* Save the address of the argument and result area. *) moveRR{source=rsp, output=rcx, opSize=nativeWordOpSize}, (* Switch to the ML stack. *) storeMemory(rsp, rbp, memRegCStackPtr, nativeWordOpSize), loadMemory(rsp, rbp, memRegStackPtr, nativeWordOpSize), (* Load the ML heap pointer. *) loadMemory(r15, rbp, memRegLocalMPointer, nativeWordOpSize), (* Now move the function closure into the closure register ready for the call. *) moveRR{source=r13, output=rdx, opSize=polyWordOpSize} ] @ (* Reload the heap base address in 32-in-64. *) ( if targetArch = ObjectId32Bit then [loadMemory(rbx, rbp, memRegSavedRbx, nativeWordOpSize)] else [] ) @ boxRegAsSysWord(rcx, rax, []) @ ( (* If we're returning a struct by reference the address for the result will have been passed in the first argument. We use that as the result area. Otherwise point to the result area on the stack. *) if resultStructByRef then loadMemory(rcx, r10, ~64, nativeWordOpSize) else ArithToGenReg{opc=ADD, output=rcx, source=NonAddressConstArg(Word.toLargeInt resultOffset), opSize=nativeWordOpSize} ) :: boxRegAsSysWord(rcx, mlArg2Reg, [rax]) @ [ (* Call the ML function using the full closure call. *) CallAddress( if targetArch = ObjectId32Bit then MemoryArg{base=rbx, index=Index4 rdx, offset=0} else MemoryArg{base=rdx, index=NoIndex, offset=0}), (* Save the ML stack pointer because we may have grown the stack. Switch to the C stack. *) storeMemory(rsp, rbp, memRegStackPtr, nativeWordOpSize), loadMemory(rsp, rbp, memRegCStackPtr, nativeWordOpSize), storeMemory(r15, rbp, memRegLocalMPointer, nativeWordOpSize) ] @ loadResults @ [ (* Remove the stack space. *) ArithToGenReg{opc=ADD, output=rsp, source=NonAddressConstArg(LargeInt.fromInt stackToAllocate), opSize=nativeWordOpSize} ] @ ( if resultStructByRef then [PopR rax] else [] ) @ [ PopR r15, PopR r14, PopR r13, PopR r12, PopR rbx, PopR rbp, (* Restore callee-save registers. *) ReturnFromFunction 0 (* Caller removes any stack arguments. *) ] end end fun foreignCall(abi: ffiABI, args: cType list, result: cType): Address.machineWord = let val code = case abi of FFI_UNIX64 => callUnix64Bits(args, result) | FFI_WIN64 => callWindows64Bits(args, result) | abi => call32Bits(abi, args, result) val functionName = "foreignCall" val debugSwitches = [(*Universal.tagInject Pretty.compilerOutputTag (Pretty.prettyPrint(print, 70)), Universal.tagInject DEBUG.assemblyCodeTag true*)] val profileObject = createProfileObject functionName val newCode = codeCreate (functionName, profileObject, debugSwitches) val closure = makeConstantClosure() val () = X86OPTIMISE.generateCode{code=newCode, labelCount=0, ops=code, resultClosure=closure} in closureAsAddress closure end (* Build a callback function. The arguments are the abi, the list of argument types and the result type. The result is an ML function that takes an ML function, f, as its argument, registers it as a callback and returns the C function as its result. When the C function is called the arguments are copied into temporary memory and the vector passed to f along with the address of the memory for the result. "f" stores the result in it when it returns and the result is then passed back as the result of the callback. N.B. This returns a closure cell which contains the address of the code. It can be used as a SysWord.word value except that while it exists the code will not be GCed. *) fun buildCallBack(abi: ffiABI, args: cType list, result: cType): Address.machineWord = let val code = case abi of FFI_UNIX64 => closureUnix64Bits(args, result) | FFI_WIN64 => closureWindows64Bits(args, result) | abi => closure32Bits(abi, args, result) val functionName = "foreignCallBack(2)" val debugSwitches = [(*Universal.tagInject Pretty.compilerOutputTag (Pretty.prettyPrint(print, 70)), Universal.tagInject DEBUG.assemblyCodeTag true*)] val profileObject = createProfileObject functionName val newCode = codeCreate (functionName, profileObject, debugSwitches) val closure = makeConstantClosure() val () = X86OPTIMISE.generateCode{code=newCode, labelCount=0, ops=code, resultClosure=closure} val stage2Code = closureAsAddress closure fun resultFunction f = let (* Generate a small function to load the address of f into rax/eax and then jump to stage2. The idea is that it should be possible to generate this eventually in a single RTS call. That could be done by using a version of this as a model. *) val codeAddress = (* In the native code versions we extract the code address from the closure. We don't do that in 32-in-64 and instead the RTS does it. *) if targetArch = ObjectId32Bit then stage2Code else Address.loadWord(Address.toAddress stage2Code, 0w0) val code = [ Move{source=AddressConstArg(Address.toMachineWord f), destination=RegisterArg rax, moveSize=opSizeToMove polyWordOpSize}, JumpAddress(AddressConstArg codeAddress) ] val functionName = "foreignCallBack(1)" val debugSwitches = [(*Universal.tagInject Pretty.compilerOutputTag (Pretty.prettyPrint(print, 70)), Universal.tagInject DEBUG.assemblyCodeTag true*)] val profileObject = createProfileObject functionName val newCode = codeCreate (functionName, profileObject, debugSwitches) val closure = makeConstantClosure() val () = X86OPTIMISE.generateCode{code=newCode, labelCount=0, ops=code, resultClosure=closure} val res = closureAsAddress closure (*val _ = print("Address is " ^ (LargeWord.toString(RunCall.unsafeCast res)) ^ "\n")*) in res end in Address.toMachineWord resultFunction end end; diff --git a/mlsource/MLCompiler/CodeTree/X86Code/X86ICodeIdentifyReferences.ML b/mlsource/MLCompiler/CodeTree/X86Code/X86ICodeIdentifyReferences.ML index 2553fc11..f79c2d60 100644 --- a/mlsource/MLCompiler/CodeTree/X86Code/X86ICodeIdentifyReferences.ML +++ b/mlsource/MLCompiler/CodeTree/X86Code/X86ICodeIdentifyReferences.ML @@ -1,914 +1,914 @@ (* - Copyright (c) 2016-19 David C.J. Matthews + Copyright (c) 2016-20 David C.J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) functor X86ICodeIdentifyReferences( structure ICODE: ICodeSig - structure DEBUG: DEBUGSIG + structure DEBUG: DEBUG structure INTSET: INTSETSIG ): X86IDENTIFYREFSSIG = struct open ICODE open INTSET type regState = { active: int, refs: int, pushState: bool, prop: regProperty } (* CC states before and after. The instruction may use the CC or ignore it. The only instructions to use the CC is X87FPGetCondition. Conditional branches are handled at the block level. The result of executing the instruction may be to set the condition code to a defined state, an undefined state or leave it unchanged. N.B. Some "instructions" may involve a stack reset that could affect the CC. *) datatype outCCState = CCSet of ccRef | CCIndeterminate | CCUnchanged and inCCState = CCNeeded of ccRef | CCUnused datatype extendedBasicBlock = ExtendedBasicBlock of { block: {instr: x86ICode, current: intSet, active: intSet, kill: intSet } list, flow: controlFlow, locals: intSet, (* Defined and used entirely within the block. *) imports: intSet, (* Defined outside the block, used inside it, but not needed afterwards. *) exports: intSet, (* Defined within the block, possibly used inside, but used outside. *) passThrough: intSet, (* Active throughout the block. May be referred to by it but needed afterwards. *) loopRegs: intSet, (* Destination registers for a loop. They will be updated by this block. *) initialStacks: intSet, (* Stack items required at the start i.e. imports+passThrough for stack items. *) inCCState: ccRef option, (* The state this block assumes. If SOME _ all predecessors must set it. *) outCCState: ccRef option (* The condition code set by this block. SOME _ if at least one successor needs it. *) } exception InternalError = Misc.InternalError (* Return the list of blocks that are the immediate successor of this. *) fun blockSuccessors(BasicBlock{flow, ...}) = successorBlocks flow (* Find the registers from an argument. *) fun argRegs(RegisterArgument rarg) = [rarg] | argRegs(MemoryLocation { base, index, cache=SOME cr, ...}) = cr :: base :: argIndex index | argRegs(MemoryLocation { base, index, cache=NONE, ...}) = base :: argIndex index | argRegs(StackLocation { cache=SOME rarg, ...}) = [rarg] | argRegs _ = [] and argIndex NoMemIndex = [] | argIndex(MemIndex1 arg) = [arg] | argIndex(MemIndex2 arg) = [arg] | argIndex(MemIndex4 arg) = [arg] | argIndex(MemIndex8 arg) = [arg] | argIndex ObjectIndex = [] fun argStacks(StackLocation { container, ...}) = [container] | argStacks(ContainerAddr { container, ...}) = [container] | argStacks _ = [] (* Return the set of registers used by the instruction. sources are registers that must have values after the instruction. dests are registers that are given values or modified by the instruction. *) fun getInstructionState(LoadArgument { source, dest, ...}) = { sources=argRegs source, dests=[dest], sStacks=argStacks source, dStacks=[], ccIn=CCUnused, ccOut=CCUnchanged } | getInstructionState(StoreArgument{ source, base, index, ...}) = { sources=argRegs source @ [base] @ argIndex index, dests=[], sStacks=argStacks source, dStacks=[], ccIn=CCUnused, ccOut=CCUnchanged } | getInstructionState(LoadMemReg { dest, ...}) = { sources=[], dests=[dest], sStacks=[], dStacks=[], ccIn=CCUnused, ccOut=CCUnchanged } | getInstructionState(StoreMemReg { source, ...}) = { sources=[source], dests=[], sStacks=[], dStacks=[], ccIn=CCUnused, ccOut=CCUnchanged } | getInstructionState(BeginFunction {regArgs, stackArgs, ...}) = { sources=[], dests=map #1 regArgs, sStacks=[], dStacks=stackArgs, ccIn=CCUnused, ccOut=CCIndeterminate } | getInstructionState(FunctionCall{regArgs, stackArgs, dest, ...}) = let (* Non-tail-recursive. Behaves as a normal reference to sources. *) fun getSources argSource = let val stackSources = List.foldl(fn (arg, srcs) => argSource arg @ srcs) [] stackArgs fun regSource((arg, _), srcs) = argSource arg @ srcs in List.foldl regSource stackSources regArgs end in { sources=getSources argRegs, dests=[dest], sStacks=getSources argStacks, dStacks=[], ccIn=CCUnused, ccOut=CCIndeterminate } end | getInstructionState(TailRecursiveCall{regArgs, stackArgs, workReg, ...}) = let (* Tail recursive call. References the argument sources but exits. *) fun getSources argSource = let val stackSources = List.foldl(fn ({src, ...}, srcs) => argSource src @ srcs) [] stackArgs fun regSource((arg, _), srcs) = argSource arg @ srcs in List.foldl regSource stackSources regArgs end in { sources=getSources argRegs, dests=[workReg], sStacks=getSources argStacks, dStacks=[], ccIn=CCUnused, ccOut=CCIndeterminate } end | getInstructionState(AllocateMemoryOperation{dest, ...}) = { sources=[], dests=[dest], sStacks=[], dStacks=[], ccIn=CCUnused, ccOut=CCIndeterminate } | getInstructionState(AllocateMemoryVariable{size, dest, ...}) = { sources=[size], dests=[dest], sStacks=[], dStacks=[], ccIn=CCUnused, ccOut=CCIndeterminate } | getInstructionState(InitialiseMem{size, addr, init}) = { sources=[size, addr, init], dests=[], sStacks=[], dStacks=[], ccIn=CCUnused, ccOut=CCUnchanged } | getInstructionState(InitialisationComplete) = (* This is just a marker. It doesn't actually generate any code. *) { sources=[], dests=[], sStacks=[], dStacks=[], ccIn=CCUnused, ccOut=CCIndeterminate } | getInstructionState(BeginLoop) = (* This is just a marker. It doesn't actually generate any code. *) { sources=[], dests=[], sStacks=[], dStacks=[], ccIn=CCUnused, ccOut=CCIndeterminate } | getInstructionState(JumpLoop{regArgs, stackArgs, workReg, ...}) = let fun getSources argSource = let val regSourceAsRegs = List.foldl(fn ((source, _), srcs) => argSource source @ srcs) [] regArgs in List.foldl(fn ((source, _, _), srcs) => argSource source @ srcs) regSourceAsRegs stackArgs end val dests = case workReg of SOME r => [r] | NONE => [] in { sources=getSources argRegs, dests=dests, sStacks=getSources argStacks, dStacks=[], ccIn=CCUnused, ccOut=CCIndeterminate } end | getInstructionState(RaiseExceptionPacket{packetReg}) = { sources=[packetReg], dests=[], sStacks=[], dStacks=[], ccIn=CCUnused, ccOut=CCIndeterminate } | getInstructionState(ReserveContainer{container, ...}) = { sources=[], dests=[], sStacks=[], dStacks=[container], ccIn=CCUnused, ccOut=CCUnchanged } | getInstructionState(IndexedCaseOperation{testReg, workReg, ...}) = { sources=[testReg], dests=[workReg], sStacks=[], dStacks=[], ccIn=CCUnused, ccOut=CCIndeterminate } | getInstructionState(LockMutable{addr}) = { sources=[addr], dests=[], sStacks=[], dStacks=[], ccIn=CCUnused, ccOut=CCIndeterminate } | getInstructionState(WordComparison{arg1, arg2, ccRef, ...}) = { sources=arg1 :: argRegs arg2, dests=[], sStacks=argStacks arg2, dStacks=[], ccIn=CCUnused, ccOut=CCSet ccRef } | getInstructionState(CompareLiteral{arg1, ccRef, ...}) = { sources=argRegs arg1, dests=[], sStacks=argStacks arg1, dStacks=[], ccIn=CCUnused, ccOut=CCSet ccRef } | getInstructionState(CompareByteMem{arg1={base, index, ...}, ccRef, ...}) = { sources=base :: argIndex index, dests=[], sStacks=[], dStacks=[], ccIn=CCUnused, ccOut=CCSet ccRef } | getInstructionState(PushExceptionHandler{workReg, ...}) = { sources=[], dests=[workReg], sStacks=[], dStacks=[], ccIn=CCUnused, ccOut=CCIndeterminate } | getInstructionState(PopExceptionHandler{ workReg }) = { sources=[], dests=[workReg], sStacks=[], dStacks=[], ccIn=CCUnused, ccOut=CCIndeterminate } | getInstructionState(BeginHandler{ workReg, packetReg, ...}) = { sources=[], dests=[packetReg, workReg], sStacks=[], dStacks=[], ccIn=CCUnused, ccOut=CCIndeterminate } | getInstructionState(ReturnResultFromFunction{resultReg, ...}) = { sources=[resultReg], dests=[], sStacks=[], dStacks=[], ccIn=CCUnused, ccOut=CCIndeterminate } | getInstructionState(ArithmeticFunction{resultReg, operand1, operand2, ccRef, ...}) = { sources=operand1 :: argRegs operand2, dests=[resultReg], sStacks=argStacks operand2, dStacks=[], ccIn=CCUnused, ccOut=CCSet ccRef } | getInstructionState(TestTagBit{arg, ccRef, ...}) = { sources=argRegs arg, dests=[], sStacks=argStacks arg, dStacks=[], ccIn=CCUnused, ccOut=CCSet ccRef } | getInstructionState(PushValue {arg, container, ...}) = { sources=argRegs arg, dests=[], sStacks=argStacks arg, dStacks=[container], ccIn=CCUnused, ccOut=CCUnchanged } | getInstructionState(CopyToCache{source, dest, ...}) = { sources=[source], dests=[dest], sStacks=[], dStacks=[], ccIn=CCUnused, ccOut=CCUnchanged} | getInstructionState(ResetStackPtr{preserveCC, ...}) = { sources=[], dests=[], sStacks=[], dStacks=[], ccIn=CCUnused, ccOut=if preserveCC then CCUnchanged else CCIndeterminate } | getInstructionState(StoreToStack {source, container, ...}) = (* Although this stores into the container it must already exist. *) { sources=argRegs source, dests=[], sStacks=container :: argStacks source, dStacks=[], ccIn=CCUnused, ccOut=CCUnchanged } | getInstructionState(TagValue{source, dest, ...}) = { sources=[source], dests=[dest], sStacks=[], dStacks=[], ccIn=CCUnused, ccOut=CCUnchanged } | getInstructionState(UntagValue{source, dest, cache, ...}) = { sources=case cache of NONE => [source] | SOME cr => [cr, source], dests=[dest], sStacks=[], dStacks=[], ccIn=CCUnused, ccOut=CCIndeterminate } | getInstructionState(LoadEffectiveAddress{base, index, dest, ...}) = let val bRegs = case base of SOME bReg => [bReg] | _ => [] val iRegs = argIndex index in { sources=bRegs @ iRegs, dests=[dest], sStacks=[], dStacks=[], ccIn=CCUnused, ccOut=CCUnchanged } end | getInstructionState(ShiftOperation{resultReg, operand, shiftAmount, ccRef, ...}) = { sources=operand :: argRegs shiftAmount, dests=[resultReg], sStacks=argStacks shiftAmount, dStacks=[], ccIn=CCUnused, ccOut=CCSet ccRef } | getInstructionState(Multiplication{resultReg, operand1, operand2, ccRef, ...}) = { sources=operand1 :: argRegs operand2, dests=[resultReg], sStacks=argStacks operand2, dStacks=[], ccIn=CCUnused, ccOut=CCSet ccRef } | getInstructionState(Division{dividend, divisor, quotient, remainder, ...}) = { sources=dividend :: argRegs divisor, dests=[quotient, remainder], sStacks=argStacks divisor, dStacks=[], ccIn=CCUnused, ccOut=CCIndeterminate } | getInstructionState(AtomicExchangeAndAdd{base, source}) = { sources=[base, source], dests=[], sStacks=[], dStacks=[], ccIn=CCUnused, ccOut=CCIndeterminate } | getInstructionState(BoxValue{source, dest, ...}) = { sources=[source], dests=[dest], sStacks=[], dStacks=[], ccIn=CCUnused, ccOut=CCIndeterminate } | getInstructionState(CompareByteVectors{vec1Addr, vec2Addr, length, ccRef, ...}) = { sources=[vec1Addr, vec2Addr, length], dests=[], sStacks=[], dStacks=[], ccIn=CCUnused, ccOut=CCSet ccRef } | getInstructionState(BlockMove{srcAddr, destAddr, length, ...}) = { sources=[srcAddr, destAddr, length], dests=[], sStacks=[], dStacks=[], ccIn=CCUnused, ccOut=CCIndeterminate } | getInstructionState(X87Compare{arg1, arg2, ccRef, ...}) = { sources=arg1 :: argRegs arg2, dests=[], sStacks=argStacks arg2, dStacks=[], ccIn=CCUnused, ccOut=CCSet ccRef } | getInstructionState(SSE2Compare{arg1, arg2, ccRef, ...}) = { sources=arg1 :: argRegs arg2, dests=[], sStacks=argStacks arg2, dStacks=[], ccIn=CCUnused, ccOut=CCSet ccRef } | getInstructionState(X87FPGetCondition{dest, ccRef, ...}) = { sources=[], dests=[dest], sStacks=[], dStacks=[], ccIn=CCNeeded ccRef, ccOut=CCIndeterminate } | getInstructionState(X87FPArith{resultReg, arg1, arg2, ...}) = { sources=arg1 :: argRegs arg2, dests=[resultReg], sStacks=argStacks arg2, dStacks=[], ccIn=CCUnused, ccOut=CCIndeterminate } | getInstructionState(X87FPUnaryOps{dest, source, ...}) = { sources=[source], dests=[dest], sStacks=[], dStacks=[], ccIn=CCUnused, ccOut=CCIndeterminate } | getInstructionState(X87Float{dest, source}) = { sources=argRegs source, dests=[dest], sStacks=argStacks source, dStacks=[], ccIn=CCUnused, ccOut=CCIndeterminate } | getInstructionState(SSE2Float{dest, source}) = { sources=argRegs source, dests=[dest], sStacks=argStacks source, dStacks=[], ccIn=CCUnused, ccOut=CCIndeterminate } | getInstructionState(SSE2FPUnary{resultReg, source, ...}) = { sources=argRegs source, dests=[resultReg], sStacks=argStacks source, dStacks=[], ccIn=CCUnused, ccOut=CCIndeterminate } | getInstructionState(SSE2FPBinary{resultReg, arg1, arg2, ...}) = { sources=arg1 :: argRegs arg2, dests=[resultReg], sStacks=argStacks arg2, dStacks=[], ccIn=CCUnused, ccOut=CCIndeterminate } | getInstructionState(TagFloat{source, dest, ...}) = { sources=[source], dests=[dest], sStacks=[], dStacks=[], ccIn=CCUnused, ccOut=CCIndeterminate } | getInstructionState(UntagFloat{source, dest, cache, ...}) = { sources=case cache of NONE => argRegs source | SOME cr => cr :: argRegs source, dests=[dest], sStacks=argStacks source, dStacks=[], ccIn=CCUnused, ccOut=CCIndeterminate } | getInstructionState(GetSSE2ControlReg{dest}) = { sources=[], dests=[dest], sStacks=[], dStacks=[], ccIn=CCUnused, ccOut=CCIndeterminate } | getInstructionState(SetSSE2ControlReg{source}) = { sources=[source], dests=[], sStacks=[], dStacks=[], ccIn=CCUnused, ccOut=CCIndeterminate } | getInstructionState(GetX87ControlReg{dest}) = { sources=[], dests=[dest], sStacks=[], dStacks=[], ccIn=CCUnused, ccOut=CCIndeterminate } | getInstructionState(SetX87ControlReg{source}) = { sources=[source], dests=[], sStacks=[], dStacks=[], ccIn=CCUnused, ccOut=CCIndeterminate } | getInstructionState(X87RealToInt{ source, dest }) = { sources=[source], dests=[dest], sStacks=[], dStacks=[], ccIn=CCUnused, ccOut=CCIndeterminate } | getInstructionState(SSE2RealToInt{ source, dest, ... }) = { sources=argRegs source, dests=[dest], sStacks=argStacks source, dStacks=[], ccIn=CCUnused, ccOut=CCIndeterminate } | getInstructionState(SignExtend32To64{ source, dest }) = { sources=argRegs source, dests=[dest], sStacks=argStacks source, dStacks=[], ccIn=CCUnused, ccOut=CCUnchanged } | getInstructionState(TouchArgument{source}) = { sources=[source], dests=[], sStacks=[], dStacks=[], ccIn=CCUnused, ccOut=CCUnchanged } (* These instructions can be eliminated if their register sources are not used. There may be other cases. *) fun eliminateable(LoadArgument _) = true | eliminateable(TagValue _) = true | eliminateable(UntagValue _) = true | eliminateable(LoadEffectiveAddress _) = true | eliminateable(BoxValue _) = true | eliminateable(CopyToCache _) = true | eliminateable(LoadMemReg _) = true | eliminateable _ = false fun identifyRegs(blockVector, pregProps): extendedBasicBlock vector * regState vector = let val maxPRegs = Vector.length pregProps val vectorLength = Vector.length blockVector (* Initial arrays - declarationArray is the set of registers given values by the block, importArray is the set of registers referenced by the block and not declared locally. *) val declarationArray = Array.array(vectorLength, emptySet) and importArray = Array.array(vectorLength, emptySet) val stackDecArray = Array.array(vectorLength, emptySet) and stackImportArray = Array.array(vectorLength, emptySet) and localLoopRegArray = Array.array(vectorLength, emptySet) (* References - this is used locally to see if a register is ever actually used and also included in the result which uses it as part of the choice of which register to spill. *) val regRefs = Array.array(maxPRegs, 0) (* Registers that must be pushed because they are required after a function call. For cache registers this means "discard". *) and requirePushOrDiscard = Array.array(maxPRegs, false) fun incrRef r = Array.update(regRefs, r, Array.sub(regRefs, r)+1) (* Contains the, possibly filtered, code for each block. *) val resultCode = Array.array(vectorLength, NONE) val ccInStates = Array.array(vectorLength, CCUnused) and ccOutStates = Array.array(vectorLength, CCIndeterminate) (* First pass - for each block build up the sets of registers defined and used in the block. We do this depth-first so that we can use "refs" to see if a register is used. If this is an instruction that can be eliminated we don't need to generate it and can ignore any references it makes. *) local fun blockScan blockNo = if isSome(Array.sub(resultCode, blockNo)) then () else let val () = Array.update(resultCode, blockNo, SOME []) (* Prevent looping. *) val thisBlock as BasicBlock { block, flow, ...} = Vector.sub(blockVector, blockNo) val successors = blockSuccessors thisBlock (* Visit everything reachable first. *) val () = List.app blockScan successors fun scanCode(instr, original as { code, decs, refs, sDecs, sRefs, occIn, occOut, loopRegs, ... }) = let val { sources, dests, sStacks=stackSrcs, dStacks=stackDests, ccIn, ccOut, ... } = getInstructionState instr fun regNo(PReg i) = i and stackNo(StackLoc{rno, ...}) = rno val destRegNos = map regNo dests and sourceRegNos = map regNo sources val stackDestRegNos = map stackNo stackDests and stackSourceRegNos = map stackNo stackSrcs (* If this instruction requires a cc i.e. is SetToCondition or X87FPGetCondition we need to set this as a requirement earlier. If this sets the CC and it is the condition we've been expecting we've satisfied it and can set the previous condition to Unused. We could use this to decide if a comparison is no longer required. That can only happen in very specific circumstances e.g. some tests in Test176.ML so it's not worthwhile. *) val newInCC = case (ccIn, ccOut, occIn) of (cc as CCNeeded _, _, _) => cc (* This instr needs a particular cc. *) | (CCUnused, CCSet _, _) => CCUnused | (CCUnused, _, occIn) => occIn (* If this instruction modifies the CC check to see if it is setting an requirement. *) val _ = case (occIn, ccOut) of (CCNeeded ccRIn, CCSet ccRout) => if ccRIn = ccRout then () else raise InternalError "CCCheck failed" | (CCNeeded _, CCIndeterminate) => raise InternalError "CCCheck failed" | _ => () (* The output CC is the last CC set. Tail instructions that don't change the CC state are ignored until we reach an instruction that sets it. *) val newOutCC = case occOut of CCUnchanged => ccOut | _ => occOut val instrLoopRegs = case instr of JumpLoop{regArgs, ...} => listToSet (map (regNo o #2) regArgs) | _ => emptySet in if eliminateable instr andalso List.all(fn dReg => Array.sub(regRefs, dReg) = 0) destRegNos then original (* Don't include this instruction. *) else let (* Only mark the sources as referred after we know we're going to need this. In that way we may eliminate the instruction that created this source. *) val () = List.app incrRef sourceRegNos in { code = instr :: code, decs = union(listToSet destRegNos, decs), refs = union(listToSet sourceRegNos, refs), sDecs = union(listToSet stackDestRegNos, sDecs), sRefs = union(listToSet stackSourceRegNos, sRefs), occIn = newInCC, occOut = newOutCC, loopRegs = union(loopRegs, instrLoopRegs)} end end (* If we have a conditional branch at the end we need the condition code. It should either be set here or in a preceding block. *) val inCC = case flow of Conditional { ccRef, ...} => CCNeeded ccRef | _ => CCUnused val { code, decs, refs, sDecs, sRefs, occIn, occOut, loopRegs, ... } = List.foldr scanCode {code=[], decs=emptySet, refs=emptySet, sDecs=emptySet, sRefs=emptySet, occIn=inCC, occOut=CCUnchanged, loopRegs=emptySet} block in Array.update(declarationArray, blockNo, decs); (* refs includes local declarations. Remove before adding to the result. *) Array.update(importArray, blockNo, minus(refs, decs)); Array.update(localLoopRegArray, blockNo, loopRegs); Array.update(stackDecArray, blockNo, sDecs); Array.update(stackImportArray, blockNo, minus(sRefs, sDecs)); Array.update(resultCode, blockNo, SOME code); Array.update(ccInStates, blockNo, occIn); Array.update(ccOutStates, blockNo, occOut) end in val () = blockScan 0 (* Start with the root block. *) end (* Second phase - Propagate reference information between the blocks. We need to consider loops here. Do a depth-first scan marking each block. If we find a loop we save the import information we've used. If when we come to process that block we find the import information is different we need to reprocess. *) (* Pass through array - values used in other blocks after this that are not declared in this block. *) val passThroughArray = Array.array(vectorLength, emptySet) val stackPassThroughArray = Array.array(vectorLength, emptySet) (* Exports - those of our declarations that are used in other blocks. *) val exportArray = Array.array(vectorLength, emptySet) val stackExportArray = Array.array(vectorLength, emptySet) (* Loop registers. This contains the registers that are not exported from or passed through this block but are used subsequently as loop registers. *) val loopRegArray = Array.array(vectorLength, emptySet) val () = Array.copy{src=localLoopRegArray, dst=loopRegArray, di=0} (* If any one of the successors requires the CC then this is set. Otherwise we leave it as Unused. *) val ccRequiredOut = Array.array(vectorLength, CCUnused) local datatype loopData = Unprocessed | Processing | Processed | Looped of { regSet: intSet, loopSet: intSet, stackSet: intSet, ccState: inCCState } fun reprocessLoop () = let val reprocess = ref false val loopArray = Array.array(vectorLength, Unprocessed) fun processBlocks blockNo = case Array.sub(loopArray, blockNo) of Processed => (* Already seen this by a different route. *) { regSet = union(Array.sub(passThroughArray, blockNo), Array.sub(importArray, blockNo)), stackSet = union(Array.sub(stackPassThroughArray, blockNo), Array.sub(stackImportArray, blockNo)), ccState = Array.sub(ccInStates, blockNo), loopSet = Array.sub(loopRegArray, blockNo) } | Looped s => s (* We've already seen this in a loop. *) | Processing => (* We have a loop. *) let (* Use the existing input array. *) val inputs = { regSet = union(Array.sub(passThroughArray, blockNo), Array.sub(importArray, blockNo)), stackSet = union(Array.sub(stackPassThroughArray, blockNo), Array.sub(stackImportArray, blockNo)), ccState = Array.sub(ccInStates, blockNo), loopSet = Array.sub(loopRegArray, blockNo) } val () = Array.update(loopArray, blockNo, Looped inputs) in inputs end | Unprocessed => (* Normal case - not visited yet. *) let val () = Array.update(loopArray, blockNo, Processing) val thisBlock = Vector.sub(blockVector, blockNo) val ourDeclarations = Array.sub(declarationArray, blockNo) and ourStackDeclarations = Array.sub(stackDecArray, blockNo) and ourLocalLoopRegs = Array.sub(localLoopRegArray, blockNo) val successors = blockSuccessors thisBlock fun addSuccessor b = let val {regSet=theirImports, stackSet=theirStackImports, ccState=theirInState, loopSet=theirLoops} = processBlocks b (* Remove loop regs from the imports if they are actually given new values by this block. We don't want to pass the old loop regs through here. *) val theirImports = minus(theirImports, ourLocalLoopRegs) (* Split the imports. If a register is a local declaration then it becomes an export. If it is not it becomes part of our passThrough. *) val (addToExp, addToImp) = INTSET.partition (fn i => member(i, ourDeclarations)) theirImports val (addToStackExp, addToStackImp) = INTSET.partition (fn i => member(i, ourStackDeclarations)) theirStackImports (* Merge the input states from each of the successors. *) val () = case (theirInState, Array.sub(ccRequiredOut, blockNo)) of (CCNeeded ts, CCNeeded req) => if ts = req then () else raise InternalError "Mismatched states" | (ts as CCNeeded _, _) => Array.update(ccRequiredOut, blockNo, ts) | _ => () (* Add loop registers to the set if they are not declared here. The only place they are declared is at the entry to the loop so that stops them being propagated further. *) val addToLoops = minus(theirLoops, ourDeclarations) in Array.update(exportArray, blockNo, union(Array.sub(exportArray, blockNo), addToExp)); Array.update(passThroughArray, blockNo, union(Array.sub(passThroughArray, blockNo), addToImp)); Array.update(stackExportArray, blockNo, union(Array.sub(stackExportArray, blockNo), addToStackExp)); Array.update(stackPassThroughArray, blockNo, union(Array.sub(stackPassThroughArray, blockNo), addToStackImp)); Array.update(loopRegArray, blockNo, union(Array.sub(loopRegArray, blockNo), addToLoops)) end val () = List.app addSuccessor successors val ourInputs = union(Array.sub(passThroughArray, blockNo), Array.sub(importArray, blockNo)) val ourStackInputs = union(Array.sub(stackPassThroughArray, blockNo), Array.sub(stackImportArray, blockNo)) in (* Check that we supply the required state. *) case (Array.sub(ccRequiredOut, blockNo), Array.sub(ccOutStates, blockNo)) of (CCNeeded ccReq, CCSet ccSet) => if ccReq = ccSet then () else raise InternalError "Mismatched cc states" | (CCNeeded _, CCIndeterminate) => raise InternalError "Mismatched cc states" | (cc as CCNeeded needOut, CCUnchanged) => ( (* We pass through the state. If we don't use the state then we need to set this as the input. If we do use the state it must be the same. *) case Array.sub(ccInStates, blockNo) of CCUnused => Array.update(ccInStates, blockNo, cc) | CCNeeded needIn => if needOut = needIn then () else raise InternalError "Mismatched cc states" ) | _ => (); (* Was this block used in a loop? If so we should not be requiring a CC. *) case Array.sub(loopArray, blockNo) of Looped {regSet, stackSet, ...} => ( case Array.sub(ccInStates, blockNo) of CCNeeded _ => raise InternalError "Looped state needs cc" | _ => (); if setToList regSet = setToList ourInputs andalso setToList stackSet = setToList ourStackInputs then () else reprocess := true ) | _ => (); Array.update(loopArray, blockNo, Processed); { regSet = ourInputs, stackSet = ourStackInputs, ccState = Array.sub(ccInStates, blockNo), loopSet=Array.sub(loopRegArray, blockNo)} end in reprocess := false; processBlocks 0; if !reprocess then reprocessLoop () else () end in val () = reprocessLoop () end (* Third pass - Build the result list with the active registers for each instruction. We don't include registers in the passThrough set since they are active throughout the block. *) local (* Number of instrs for which this is active. We use this to try to select a register to push to the stack if we have too many. Registers that have only a short lifetime are less likely to be pushed than those that are active longer. *) val regActive = Array.array(maxPRegs, 0) fun addActivity n r = Array.update(regActive, r, Array.sub(regActive, r)+n) fun createResultInstrs (passThrough, stackPassThrough) (instr, (tail, activeAfterThis, stackActiveAfterThis)) = let val { sources, dests, sStacks=stackSrcs, dStacks=stackDests, ... } = getInstructionState instr in (* Eliminate instructions if their results are not required. The earlier check for this will remove most cases but if we have duplicated a block we may have a register that is required elsewhere but not in this particular branch. *) if not(List.exists(fn PReg d => member(d, activeAfterThis)) dests) andalso eliminateable instr then (tail, activeAfterThis, stackActiveAfterThis) else let fun regNo(PReg i) = i fun stackNo(StackLoc{rno, ...}) = rno val destRegNos = map regNo dests and sourceRegNos = map regNo sources val destSet = listToSet destRegNos (* Remove any sources that are present in passThrough since they are going to be active throughout the block. *) and sourceSet = minus(listToSet sourceRegNos, passThrough) val stackDestRegNos = map stackNo stackDests and stackSourceRegNos = map stackNo stackSrcs val stackDestSet = listToSet stackDestRegNos and stackSourceSet = minus(listToSet stackSourceRegNos, stackPassThrough) (* To compute the active set for the PREVIOUS instruction (we're processing from the end back to the start) we remove any registers that have been given values in this instruction and add anything that we are using in this instruction since they will now need to have values. *) val afterRemoveDests = minus(activeAfterThis, destSet) val stackAfterRemoveDests = minus(stackActiveAfterThis, stackDestSet) val activeForPrevious = union(sourceSet, afterRemoveDests) val stackActiveForPrevious = union(stackSourceSet, stackAfterRemoveDests) (* The "active" set is the set of registers that need to be active DURING the instruction. It includes destinations, which will usually be in "activeAfterThis", because there may be destinations that are not actually used subsequently but still need a register. That will also include work registers. Usually sources aren't included if this is the last use but the AllocateMemoryVariable "instruction" can't set the size after the memory is allocated so the active set includes the source(s). *) val activeForInstr = case instr of FunctionCall _ => sourceSet (* Is this still needed? *) | TailRecursiveCall _ => (* Set the active set to the total set of registers we require including the work register. This ensures that we will spill as many registers as we require when we look at the size of the active set. *) union(sourceSet, destSet) | AllocateMemoryVariable _ => (* We can only set the size after the memory is allocated. *) union(activeAfterThis, union(sourceSet, destSet)) | BoxValue _ => (* We can only store the value in the box after the box is allocated. *) union(activeAfterThis, union(sourceSet, destSet)) | _ => union(activeAfterThis, destSet) val () = List.app(addActivity 1) (setToList activeForInstr) local (* If we are allocating memory we have to save the current registers if they could contain an address. We mustn't push untagged registers and we mustn't push the destination. *) fun getSaveSet dReg = let val activeAfter = union(activeAfterThis, passThrough) (* Remove any registers marked - must-not-push. These are registers holding non-address values. They will actually be saved by the RTS across any GC but not checked or modified by the GC. Exclude the result register. *) fun getSave i = if i = dReg then NONE else case Vector.sub(pregProps, i) of RegPropGeneral => SOME(PReg i) | RegPropCacheTagged => SOME(PReg i) | RegPropUntagged => NONE | RegPropStack _ => NONE | RegPropCacheUntagged => NONE | RegPropMultiple => raise InternalError "getSave: RegPropMultiple" in List.mapPartial getSave (setToList activeAfter) end in (* Sometimes we need to modify the instruction e.g. to include the set of registers to save. *) val convertedInstr = case instr of AllocateMemoryOperation{size, flags, dest, saveRegs=_} => AllocateMemoryOperation{size=size, flags=flags, dest=dest, saveRegs=getSaveSet(regNo dest)} | AllocateMemoryVariable{size, dest, saveRegs=_} => AllocateMemoryVariable{size=size, dest=dest, saveRegs=getSaveSet(regNo dest)} | BoxValue{source, dest, boxKind, saveRegs=_} => BoxValue{source=source, dest=dest, boxKind=boxKind, saveRegs=getSaveSet(regNo dest)} | JumpLoop{regArgs, stackArgs, checkInterrupt = SOME _, workReg, ...} => let (* If we have to check for interrupts we must preserve registers across the RTS call. *) fun getSave i = case Vector.sub(pregProps, i) of RegPropGeneral => SOME(PReg i) | RegPropCacheTagged => SOME(PReg i) | RegPropUntagged => NONE | RegPropStack _ => NONE | RegPropCacheUntagged => NONE | RegPropMultiple => raise InternalError "getSave: RegPropMultiple" val currentRegs = union(activeAfterThis, passThrough) (* Have to include the loop registers. These were previously included automatically because they were part of the import set. *) val check = List.mapPartial getSave (map (regNo o #2) regArgs @ setToList currentRegs) in JumpLoop{regArgs=regArgs, stackArgs=stackArgs, checkInterrupt=SOME check, workReg=workReg} end | FunctionCall{regArgs, stackArgs=[], dest, realDest, callKind as ConstantCode m, saveRegs=_} => (* If this is arbitrary precision push the registers rather than marking them as "save". stringOfWord returns 'CODE "PolyAddArbitrary"' etc. *) if (String.isSubstring "Arbitrary\"" (Address.stringOfWord m)) then FunctionCall{regArgs=regArgs, stackArgs=[], callKind=callKind, dest=dest, realDest=realDest, saveRegs=getSaveSet(regNo dest) } else instr | instr as LoadArgument{dest=PReg dreg, ...} => ( if member(dreg, activeAfterThis) then () else print("Register " ^ Int.toString dreg ^ " inactive-" ^ PolyML.makestring instr ^ "\n"); instr ) | _ => instr end (* FunctionCall must mark all registers as "push". *) local fun pushRegisters () = let val activeAfter = union(activeAfterThis, passThrough) fun pushAllButDests i = if List.exists(fn j => i=j) destRegNos then () else case Vector.sub(pregProps, i) of RegPropCacheTagged => raise InternalError "pushRegisters: cache reg" | RegPropCacheUntagged => raise InternalError "pushRegisters: cache reg" | _ => Array.update(requirePushOrDiscard, i, true) in (* We need to push everything active after this except the result register. *) List.app pushAllButDests (setToList activeAfter) end in val () = case instr of FunctionCall{ stackArgs=[], callKind=ConstantCode m, ...} => if (String.isSubstring "Arbitrary\"" (Address.stringOfWord m)) then () else pushRegisters () | FunctionCall _ => pushRegisters () (* It should no longer be necessary to push across a handler but there still seem to be cases that need it. *) | BeginHandler _ => pushRegisters () | CopyToCache {source=PReg srcReg, dest=PReg dstReg, ...} => (* If the source is a cache register marked as "must push" i.e. discard, the destination must also be discarded i.e. not available. Note: the source could be a non-cache register marked for pushing. *) ( case (Vector.sub(pregProps, srcReg), Array.sub(requirePushOrDiscard, srcReg)) of (RegPropCacheTagged, true) => Array.update(requirePushOrDiscard, dstReg, true) | (RegPropCacheUntagged, true) => Array.update(requirePushOrDiscard, dstReg, true) | _ => () ) | _ => () end (* Which entries are active in this instruction but not afterwards? *) val kill = union(minus(stackSourceSet, stackActiveAfterThis), minus(sourceSet, activeAfterThis)) in ({instr=convertedInstr, active=activeForInstr, current=activeAfterThis, kill=kill} :: tail, activeForPrevious, stackActiveForPrevious) end end fun createResult blockNo = let val BasicBlock{ flow, ...} = Vector.sub(blockVector, blockNo) val declSet = Array.sub(declarationArray, blockNo) and importSet = Array.sub(importArray, blockNo) and passSet = Array.sub(passThroughArray, blockNo) and loopSet = Array.sub(loopRegArray, blockNo) and exportSet = Array.sub(exportArray, blockNo) and stackPassSet = Array.sub(stackPassThroughArray, blockNo) and stackImportSet = Array.sub(stackImportArray, blockNo) and stackExportSet = Array.sub(stackExportArray, blockNo) val filteredCode = getOpt(Array.sub(resultCode, blockNo), []) (* At the end of the block we should have the exports active. *) val (resultInstrs, _, _) = List.foldr (createResultInstrs (passSet, stackPassSet)) ([], exportSet, stackExportSet) filteredCode (* Set the active count for the pass through. *) val instrCount = List.length filteredCode val () = List.app(addActivity instrCount) (setToList passSet) val inCCState = case Array.sub(ccInStates, blockNo) of CCNeeded s => SOME s | CCUnused => NONE val outCCState = case Array.sub(ccRequiredOut, blockNo) of CCNeeded s => SOME s | CCUnused => NONE in ExtendedBasicBlock { block = resultInstrs, flow=flow, locals = minus(declSet, exportSet), imports = importSet, exports = exportSet, passThrough = passSet, loopRegs = loopSet, initialStacks = union(stackPassSet, stackImportSet), inCCState = inCCState, outCCState = outCCState } end in val resultBlocks = Vector.tabulate(vectorLength, createResult) val regActive = regActive end val registerState: regState vector = Vector.tabulate(maxPRegs, fn i => { active = Array.sub(regActive, i), refs = Array.sub(regRefs, i), pushState = Array.sub(requirePushOrDiscard, i), prop = Vector.sub(pregProps, i) } ) in (resultBlocks, registerState) end (* Exported function. First filter out unreferenced blocks then process the registers themselves. *) fun identifyRegisters(blockVector, pregProps) = let val vectorLength = Vector.length blockVector val mapArray = Array.array(vectorLength, NONE) and resArray = Array.array(vectorLength, NONE) val count = ref 0 fun setReferences label = case Array.sub(mapArray, label) of NONE => (* Not yet visited *) let val BasicBlock{flow, block} = Vector.sub(blockVector, label) (* Create a new entry for it. *) val newLabel = ! count before count := !count + 1 (* Add it to the map. Any other references will use this without reprocessing. *) val () = Array.update(mapArray, label, SOME newLabel) val newFlow = case flow of Unconditional l => Unconditional(setReferences l) | Conditional{trueJump, falseJump, ccRef, condition} => Conditional{trueJump=setReferences trueJump, falseJump=setReferences falseJump, ccRef=ccRef, condition=condition} | ExitCode => ExitCode | IndexedBr list => IndexedBr(map setReferences list) | SetHandler{handler, continue} => SetHandler{handler=setReferences handler, continue=setReferences continue} | UnconditionalHandle l => UnconditionalHandle(setReferences l) | ConditionalHandle{handler, continue} => ConditionalHandle{handler=setReferences handler, continue=setReferences continue} val () = Array.update(resArray, newLabel, SOME(BasicBlock{flow=newFlow, block=block})) in newLabel end | SOME lab => lab val _ = setReferences 0 val newBlockVector = Vector.tabulate(!count, fn i => valOf(Array.sub(resArray, i))) in identifyRegs(newBlockVector, pregProps) end (* Exported for use in GetConflictSets *) fun getInstructionRegisters instr = let val {sources, dests, ...} = getInstructionState instr in {sources=sources, dests=dests} end (* Exported for use in ICodeOptimise *) val getInstructionCC = #ccOut o getInstructionState structure Sharing = struct type x86ICode = x86ICode and reg = reg and preg = preg and intSet = intSet and basicBlock = basicBlock and extendedBasicBlock = extendedBasicBlock and controlFlow = controlFlow and argument = argument and memoryIndex = memoryIndex and regProperty = regProperty and ccRef = ccRef and outCCState = outCCState end end; diff --git a/mlsource/MLCompiler/CodeTree/X86Code/X86ICodeOptimise.ML b/mlsource/MLCompiler/CodeTree/X86Code/X86ICodeOptimise.ML index 8c2c6e8c..a07bf9a1 100644 --- a/mlsource/MLCompiler/CodeTree/X86Code/X86ICodeOptimise.ML +++ b/mlsource/MLCompiler/CodeTree/X86Code/X86ICodeOptimise.ML @@ -1,413 +1,413 @@ (* - Copyright David C. J. Matthews 2018-19 + Copyright David C. J. Matthews 2018-20 This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) functor X86ICodeOptimise( structure ICODE: ICodeSig structure INTSET: INTSETSIG structure IDENTIFY: X86IDENTIFYREFSSIG structure X86CODE: X86CODESIG (* For invertTest. *) - structure DEBUG: DEBUGSIG + structure DEBUG: DEBUG structure PRETTY: PRETTYSIG sharing ICODE.Sharing = IDENTIFY.Sharing = INTSET = X86CODE ): X86ICODEOPTSIG = struct open ICODE open INTSET open IDENTIFY val InternalError = Misc.InternalError datatype optimise = Changed of basicBlock vector * regProperty vector | Unchanged (* Optimiser. This could incorporate optimisations done elsewhere. IdentifyReferences currently removes instructions that produce results in registers that are never used. PushRegisters deals with caching. Caching involves speculative changes that can be reversed if there is a need to spill registers. The optimiser currently deals with booleans and conditions and with moving memory loads into an instruction operand. *) (* This is a rewrite of the last instruction to set a boolean. This is almost always rewriting the next instruction. The only possibility is that we have a ResetStackPtr in between. *) datatype boolRegRewrite = BRNone (* BRSetConditionToConstant - we have a comparison of two constant value. This will usually happen because we've duplicated a branch and set a register to a constant which we then compare. *) | BRSetConditionToConstant of { srcCC: ccRef, signedCompare: order, unsignedCompare: order } fun optimiseICode{ code, pregProps, ccCount=_, debugSwitches=_ } = let val hasChanged = ref false val regCounter = ref(Vector.length pregProps) val regList = ref [] fun newReg kind = ( regList := kind :: ! regList; PReg (!regCounter) ) before regCounter := !regCounter + 1 (* If this argument is a register and the register is mapped to a memory location, a constant or another register replace the value. Memory locations are only replaced if this is the only use. If there is more than one reference it's better to load it into a register and retain the register references. *) fun replaceWithValue(arg as RegisterArgument (preg as PReg pregNo), kill, regMap, instrOpSize) = ( case List.find(fn {dest, ... } => dest = preg) regMap of SOME { source as MemoryLocation _, opSize, ...} => ( if member(pregNo, kill) andalso opSize = instrOpSize then ( hasChanged := true; source ) else arg, (* Filter this from the list. If this is not the last reference we want to use the register and if it is then we don't need it any longer. *) List.filter(fn {dest, ...} => dest <> preg) regMap ) | SOME { source, ...} => ( source, (* Filter it if it is the last reference. *) if member(pregNo, kill) then List.filter(fn {dest, ...} => dest <> preg) regMap else regMap ) | NONE => (arg, regMap) ) | replaceWithValue(arg, _, regMap, _) = (arg, regMap) fun optimiseBlock processed (block, flow, outCCState) = let fun optCode([], brCond, regMap, code) = (code, brCond, regMap) | optCode({instr=CompareLiteral{arg1, arg2, ccRef=ccRefOut, opSize}, kill, ...} :: rest, _, regMap, code) = let val (repArg1, memRefsOut) = replaceWithValue(arg1, kill, regMap, opSize) in case repArg1 of IntegerConstant test => (* CompareLiteral is put in by CodetreeToIcode to test a boolean value. It can also arise as the result of pattern matching on booleans or even by tests such as = true. If the source register is now a constant we want to propagate the constant condition. *) let (* This comparison reduces to a constant. *) val _ = hasChanged := true (* Put in a replacement so that if we were previously testing ccRefOut we should instead test ccRef. *) val repl = BRSetConditionToConstant{srcCC=ccRefOut, signedCompare=LargeInt.compare(test, arg2), (* Unsigned tests. We converted the values from Word to LargeInt. We can therefore turn the tests back to Word for the unsigned comparisons. *) unsignedCompare=Word.compare(Word.fromLargeInt test, Word.fromLargeInt arg2)} val _ = isSome outCCState andalso raise InternalError "optCode: CC exported" in optCode(rest, repl, memRefsOut, code) end | repArg1 => optCode(rest, BRNone, memRefsOut, CompareLiteral{arg1=repArg1, arg2=arg2, ccRef=ccRefOut, opSize=opSize}::code) end | optCode({instr=LoadArgument{dest, source, kind=Move64Bit}, kill, ...} :: rest, inCond, regMap, code) = let val (repSource, mapAfterReplace) = replaceWithValue(source, kill, regMap, OpSize64) (* If the value is a constant or memory after replacement we include this. *) val mapOut = if (case repSource of MemoryLocation _ => true | IntegerConstant _ => true | _ => false) then {dest=dest, source=repSource, opSize=OpSize64} :: mapAfterReplace else mapAfterReplace val outInstr = LoadArgument{dest=dest, source=repSource, kind=Move64Bit} in optCode(rest, inCond, mapOut, outInstr::code) end | optCode({instr=LoadArgument{dest, source, kind=Move32Bit}, kill, ...} :: rest, inCond, regMap, code) = let val (repSource, mapAfterReplace) = replaceWithValue(source, kill, regMap, OpSize32) val mapOut = if (case repSource of MemoryLocation _ => true | IntegerConstant _ => true | _ => false) then {dest=dest, source=repSource, opSize=OpSize32} :: mapAfterReplace else mapAfterReplace val outInstr = LoadArgument{dest=dest, source=repSource, kind=Move32Bit} in optCode(rest, inCond, mapOut, outInstr::code) end | optCode({instr as LoadArgument{dest, source as MemoryLocation _, kind} , ...} :: rest, inCond, regMap, code) = let (* If we load a memory location add it to the list in case we can use it later. *) val memRefsOut = case kind of Move64Bit => {dest=dest, source=source, opSize=OpSize64} :: regMap | Move32Bit => {dest=dest, source=source, opSize=OpSize32} :: regMap | _ => regMap in optCode(rest, inCond, memRefsOut, instr::code) end | optCode({instr as StoreArgument _, ...} :: rest, inCond, _, code) = (* This may change a value in memory. For safety remove everything. *) optCode(rest, inCond, [], instr::code) | optCode({instr as FunctionCall _, ...} :: rest, _, _, code) = optCode(rest, BRNone, [], instr::code) | optCode({instr as BeginLoop, ...} :: rest, _, _, code) = (* Any register value from outside the loop are not valid inside. *) optCode(rest, BRNone, [], instr::code) | optCode({instr as JumpLoop _, ...} :: rest, _, _, code) = (* Likewise at the end of the loop. Not sure if this is essential. *) optCode(rest, BRNone, [], instr::code) (* These instructions could take memory operands. This isn't the full set but the others are rare or only take memory operands that refer to boxed memory. *) | optCode({instr=WordComparison{arg1, arg2, ccRef, opSize}, kill, ...} :: rest, _, regMap, code) = let (* Replace register reference with memory if possible. *) val (source, memRefsOut) = replaceWithValue(arg2, kill, regMap, opSize) in (* This affects the CC. *) optCode(rest, BRNone, memRefsOut, WordComparison{arg1=arg1, arg2=source, ccRef=ccRef, opSize=opSize}::code) end | optCode({instr=ArithmeticFunction{oper, resultReg, operand1, operand2, ccRef, opSize}, kill, ...} :: rest, _, regMap, code) = let (* Replace register reference with memory if possible. *) val (source, memRefsOut) = replaceWithValue(operand2, kill, regMap, opSize) in (* This affects the CC. *) optCode(rest, BRNone, memRefsOut, ArithmeticFunction{oper=oper, resultReg=resultReg, operand1=operand1, operand2=source, ccRef=ccRef, opSize=opSize}::code) end | optCode({instr as TestTagBit{arg, ccRef}, kill, ...} :: rest, _, regMap, code) = let (* Replace register reference with memory. In some circumstances it can try to replace it with a constant. Since we don't code-generate that case we need to filter it out and retain the original register. *) val (source, memRefsOut) = replaceWithValue(arg, kill, regMap, polyWordOpSize) val resultInstr = case source of IntegerConstant _ => instr (* Use original *) | AddressConstant _ => instr | _ => TestTagBit{arg=source, ccRef=ccRef} in (* This affects the CC. *) optCode(rest, BRNone, memRefsOut, resultInstr::code) end | optCode({instr=UntagFloat{source, dest, cache=_}, kill, ...} :: rest, _, regMap, code) = let (* Replace register reference with memory if possible. *) val (source, memRefsOut) = replaceWithValue(source, kill, regMap, polyWordOpSize) in (* Not sure if this affects the CC but assume it might. *) optCode(rest, BRNone, memRefsOut, UntagFloat{source=source, dest=dest, cache=NONE}::code) end | optCode({instr, ...} :: rest, inCond, regMap, code) = let (* If this instruction affects the CC the cached SetToCondition will no longer be valid. *) val afterCond = case getInstructionCC instr of CCUnchanged => inCond | _ => BRNone in optCode(rest, afterCond, regMap, instr::code) end val (blkCode, finalRepl, finalMap) = optCode(block, BRNone, [], processed) in case (flow, finalRepl) of (* We have a Condition and a change to the condition. *) (flow as Conditional{ccRef, condition, trueJump, falseJump}, BRSetConditionToConstant({srcCC, signedCompare, unsignedCompare, ...})) => if srcCC = ccRef then let val testResult = case (condition, signedCompare, unsignedCompare) of (JE, EQUAL, _) => true | (JE, _, _) => false | (JNE, EQUAL, _) => false | (JNE, _, _) => true | (JL, LESS, _) => true | (JL, _, _) => false | (JG, GREATER,_) => true | (JG, _, _) => false | (JLE, GREATER,_) => false | (JLE, _, _) => true | (JGE, LESS, _) => false | (JGE, _, _) => true | (JB, _, LESS ) => true | (JB, _, _) => false | (JA, _,GREATER) => true | (JA, _, _) => false | (JNA, _,GREATER) => false | (JNA, _, _) => true | (JNB, _, LESS ) => false | (JNB, _, _) => true (* The overflow and parity checks should never occur. *) | _ => raise InternalError "getCondResult: comparison" val newFlow = if testResult then Unconditional trueJump else Unconditional falseJump val() = hasChanged := true in BasicBlock{flow=newFlow, block=List.rev blkCode} end else BasicBlock{flow=flow, block=List.rev blkCode} | (flow as Unconditional jmp, _) => let val ExtendedBasicBlock{block=targetBlck, locals, exports, flow=targetFlow, outCCState=targetCC, ...} = Vector.sub(code, jmp) (* If the target is empty or is simply one or more Resets or a Return we're better off merging this in rather than doing the jump. We allow a single Load e.g. when loading a constant or moving a register. If we have a CompareLiteral and we're comparing with a register in the map that has been set to a constant we include that because the comparison will then be reduced to a constant. *) fun isSimple([], _, _) = true | isSimple ({instr=ResetStackPtr _, ...} :: instrs, moves, regMap) = isSimple(instrs, moves, regMap) | isSimple ({instr=ReturnResultFromFunction _, ...} :: instrs, moves, regMap) = isSimple(instrs, moves, regMap) | isSimple ({instr=RaiseExceptionPacket _, ...} :: instrs, moves, regMap) = isSimple(instrs, moves, regMap) | isSimple ({instr=LoadArgument{source=RegisterArgument preg, dest, kind=Move64Bit}, ...} :: instrs, moves, regMap) = let (* We frequently have a move of the original register into a new register before the test. *) val newMap = case List.find(fn {dest, ... } => dest = preg) regMap of SOME {source, ...} => {dest=dest, source=source, opSize=OpSize64} :: regMap | NONE => regMap in moves = 0 andalso isSimple(instrs, moves+1, newMap) end | isSimple ({instr=LoadArgument{source=RegisterArgument preg, dest, kind=Move32Bit}, ...} :: instrs, moves, regMap) = let (* We frequently have a move of the original register into a new register before the test. *) val newMap = case List.find(fn {dest, ... } => dest = preg) regMap of SOME {source, ...} => {dest=dest, source=source, opSize=OpSize32} :: regMap | NONE => regMap in moves = 0 andalso isSimple(instrs, moves+1, newMap) end | isSimple ({instr=LoadArgument _, ...} :: instrs, moves, regMap) = moves = 0 andalso isSimple(instrs, moves+1, regMap) | isSimple ({instr=CompareLiteral{arg1=RegisterArgument preg, ...}, ...} :: instrs, moves, regMap) = let val isReplace = List.find(fn {dest, ... } => dest = preg) regMap in case isReplace of SOME {source=IntegerConstant _, ...} => isSimple(instrs, moves, regMap) | _ => false end | isSimple _ = false in (* Merge trivial blocks. This previously also tried to merge non-trivial blocks if they only had one reference but this ends up duplicating non-trivial code. If we have a trivial block that has multiple references but is the only reference to a non-trivial block we can merge the non-trivial block into it. That would be fine except that at the same time we may merge this trivial block elsewhere. *) (* The restriction that a block must only export "merge" registers is unfortunate but necessary to avoid the situation where a non-merge register is defined at multiple points and cannot be pushed to the stack. This really isn't an issue with blocks with unconditional branches but there are cases where we have successive tests of the same condition and that results in local registers being defined and then exported. This occurs in, for example, fun f x = if x > "abcde" then "yes" else "no"; *) if isSimple(targetBlck, 0, finalMap) andalso List.all (fn i => Vector.sub(pregProps, i) = RegPropMultiple) (setToList exports) then let (* Copy the block, creating new registers for the locals. *) val localMap = List.map (fn r => (PReg r, newReg(Vector.sub(pregProps, r)))) (setToList locals) fun mapReg r = case List.find (fn (s, _) => r = s) localMap of SOME(_, s) => s | NONE => r fun mapIndex(MemIndex1 r) = MemIndex1(mapReg r) | mapIndex(MemIndex2 r) = MemIndex2(mapReg r) | mapIndex(MemIndex4 r) = MemIndex4(mapReg r) | mapIndex(MemIndex8 r) = MemIndex8(mapReg r) | mapIndex index = index fun mapArg(RegisterArgument r) = RegisterArgument(mapReg r) | mapArg(MemoryLocation{base, offset, index, ...}) = MemoryLocation{base=mapReg base, offset=offset, index=mapIndex index, cache=NONE} | mapArg arg = arg fun mapInstr(instr as ResetStackPtr _) = instr | mapInstr(ReturnResultFromFunction{resultReg, realReg, numStackArgs}) = ReturnResultFromFunction{resultReg=mapReg resultReg, realReg=realReg, numStackArgs=numStackArgs} | mapInstr(RaiseExceptionPacket{packetReg}) = RaiseExceptionPacket{packetReg=mapReg packetReg} | mapInstr(LoadArgument{source, dest, kind}) = LoadArgument{source=mapArg source, dest=mapReg dest, kind=kind} | mapInstr(CompareLiteral{arg1, arg2, opSize, ccRef}) = CompareLiteral{arg1=mapArg arg1, arg2=arg2, opSize=opSize, ccRef=ccRef} | mapInstr _ = raise InternalError "mapInstr: other instruction" fun mapRegNo i = case(mapReg(PReg i)) of PReg r => r (* Map the instructions and the sets although we only use the kill set. *) fun mapCode{instr, current, active, kill} = {instr=mapInstr instr, current=listToSet(map mapRegNo (setToList current)), active=listToSet(map mapRegNo (setToList active)), kill=listToSet(map mapRegNo (setToList kill))} in hasChanged := true; optimiseBlock blkCode(map mapCode targetBlck, targetFlow, targetCC) end else BasicBlock{flow=flow, block=List.rev blkCode} end | (flow, _) => BasicBlock{flow=flow, block=List.rev blkCode} end fun optBlck(ExtendedBasicBlock{block, flow, outCCState, ...}) = optimiseBlock [] (block, flow, outCCState) val resVector = Vector.map optBlck code in if !hasChanged then let val extraRegs = List.rev(! regList) val props = if null extraRegs then pregProps else Vector.concat[pregProps, Vector.fromList extraRegs] in Changed(resVector, props) end else Unchanged end structure Sharing = struct type extendedBasicBlock = extendedBasicBlock and basicBlock = basicBlock and regProperty = regProperty and optimise = optimise end end; diff --git a/mlsource/MLCompiler/CodeTree/X86Code/X86ICodeToX86Code.ML b/mlsource/MLCompiler/CodeTree/X86Code/X86ICodeToX86Code.ML index 81d0029c..7c6fc143 100644 --- a/mlsource/MLCompiler/CodeTree/X86Code/X86ICodeToX86Code.ML +++ b/mlsource/MLCompiler/CodeTree/X86Code/X86ICodeToX86Code.ML @@ -1,2126 +1,2126 @@ (* - Copyright David C. J. Matthews 2016-19 + Copyright David C. J. Matthews 2016-20 This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) functor X86ICodeToX86Code( structure X86CODE: X86CODESIG structure X86OPTIMISE: sig type operation type code type operations = operation list type closureRef val generateCode: {code: code, ops: operations, labelCount: int, resultClosure: closureRef } -> unit structure Sharing: sig type operation = operation type code = code type closureRef = closureRef end end - structure DEBUG: DEBUGSIG + structure DEBUG: DEBUG structure ICODE: ICodeSig structure IDENTIFY: X86IDENTIFYREFSSIG structure INTSET: INTSETSIG structure PRETTY: PRETTYSIG structure STRONGLY: sig val stronglyConnectedComponents: {nodeAddress: 'a -> int, arcs: 'a -> int list } -> 'a list -> 'a list list end sharing X86CODE.Sharing = ICODE.Sharing = X86OPTIMISE.Sharing = IDENTIFY.Sharing = INTSET ): X86ICODEGENERATESIG = struct open IDENTIFY open ICODE open X86CODE open Address exception InternalError = Misc.InternalError fun asGenReg(GenReg r) = r | asGenReg _ = raise InternalError "asGenReg" and asFPReg(FPReg r) = r | asFPReg _ = raise InternalError "asFPReg" and asXMMReg(XMMReg r) = r | asXMMReg _ = raise InternalError "asXMMReg" (* tag a short constant *) fun tag c = 2 * c + 1 local val regs = case targetArch of Native32Bit => [edi, esi, edx, ecx, ebx, eax] | Native64Bit => [r14, r13, r12, r11, r10, r9, r8, edi, esi, edx, ecx, ebx, eax] | ObjectId32Bit => [r14, r13, r12, r11, r10, r9, r8, edi, esi, edx, ecx, eax] in val generalRegisters = List.map GenReg regs end fun opSizeToMove OpSize32 = Move32 | opSizeToMove OpSize64 = Move64 fun icodeToX86Code{blocks, functionName, stackRequired, debugSwitches, allocatedRegisters, resultClosure, ...} = let fun argAsGenReg(RegisterArg(GenReg r)) = r | argAsGenReg _ = raise InternalError "argAsGenReg" fun sourceAsGenRegOrMem(RegisterArg(GenReg r)) = RegisterArg r | sourceAsGenRegOrMem(MemoryArg{offset, base=baseReg, index}) = MemoryArg{base=baseReg, offset=offset, index=index} | sourceAsGenRegOrMem(NonAddressConstArg v) = NonAddressConstArg v | sourceAsGenRegOrMem(AddressConstArg v) = AddressConstArg v | sourceAsGenRegOrMem _ = raise InternalError "sourceAsGenRegOrMem" and sourceAsXMMRegOrMem(RegisterArg(XMMReg r)) = RegisterArg r | sourceAsXMMRegOrMem(MemoryArg{offset, base=baseReg, index}) = MemoryArg{base=baseReg, offset=offset, index=index} | sourceAsXMMRegOrMem(NonAddressConstArg v) = NonAddressConstArg v | sourceAsXMMRegOrMem(AddressConstArg v) = AddressConstArg v | sourceAsXMMRegOrMem _ = raise InternalError "sourceAsGenRegOrMem" (* Moves and loads. *) fun llLoadArgument({ source, dest=GenReg destReg, kind=Move64Bit}, code) = Move { source=sourceAsGenRegOrMem source, destination=RegisterArg destReg, moveSize=Move64 } :: code | llLoadArgument({ source=MemoryArg mLoc, dest=GenReg destReg, kind=MoveByte}, code) = (* Load from memory. *) Move{moveSize=Move8, source=MemoryArg mLoc, destination=RegisterArg destReg} :: code | llLoadArgument({ source=MemoryArg mLoc, dest=GenReg destReg, kind=Move16Bit}, code) = (* Load from memory. *) Move{moveSize=Move16, source=MemoryArg mLoc, destination=RegisterArg destReg} :: code | llLoadArgument({ source, dest=GenReg destReg, kind=Move32Bit}, code) = (* Load from memory. *) Move { source=sourceAsGenRegOrMem source, destination=RegisterArg destReg, moveSize=Move32 } :: code (* Load a floating point value. *) | llLoadArgument({source=MemoryArg{offset, base=baseReg, index}, dest=FPReg fpReg, kind=MoveDouble}, code) = moveToOutputFP(fpReg, FPLoadFromMemory{ address={base=baseReg, offset=offset, index=index}, precision=DoublePrecision } :: code) | llLoadArgument({source=AddressConstArg addrConst, dest=FPReg fpReg, kind=MoveDouble}, code) = moveToOutputFP(fpReg, FPLoadFromConst{ constant= addrConst, precision=DoublePrecision } :: code) | llLoadArgument({source=RegisterArg(FPReg fpSrc), dest=FPReg fpDest, kind=MoveDouble}, code) = (* Moving from one FP reg to another. Even if we are moving from FP0 we still do a load because FPStoreToFPReg adds one to the register number to account for one value on the stack. *) moveToOutputFP(fpDest, FPLoadFromFPReg{source=fpSrc, lastRef=false} :: code) (* Load or move from an XMM reg. *) | llLoadArgument({source, dest=XMMReg xmmRegReg, kind=MoveDouble}, code) = XMMArith { opc= SSE2MoveDouble, source=sourceAsXMMRegOrMem source, output=xmmRegReg } :: code (* Load a floating point value. *) | llLoadArgument({source=MemoryArg{offset, base=baseReg, index}, dest=FPReg fpReg, kind=MoveFloat}, code) = moveToOutputFP(fpReg, FPLoadFromMemory{ address={ base=baseReg, offset=offset, index=index }, precision=SinglePrecision } :: code) | llLoadArgument({source=AddressConstArg addrConst, dest=FPReg fpReg, kind=MoveFloat}, code) = moveToOutputFP(fpReg, FPLoadFromConst{ constant= addrConst, precision=SinglePrecision } :: code) (* Load or move from an XMM reg. *) | llLoadArgument({source, dest=XMMReg xmmRegReg, kind=MoveFloat}, code) = XMMArith { opc= SSE2MoveFloat, source=sourceAsXMMRegOrMem source, output=xmmRegReg } :: code (* Any other combinations are not allowed. *) | llLoadArgument _ = raise InternalError "codeGenICode: LoadArgument" (* Unless the destination is FP0 we need to store and pop. *) and moveToOutputFP(fpDest, code) = if fpDest = fp0 then code else FPStoreToFPReg{output=fpDest, andPop=true} :: code (* Store to memory *) fun llStoreArgument{ source=RegisterArg(GenReg sourceReg), base, offset, index, kind=Move64Bit} = Move{source=RegisterArg sourceReg, destination=MemoryArg {base=base, offset=offset, index=index}, moveSize=opSizeToMove OpSize64} | llStoreArgument{ source=RegisterArg(GenReg sourceReg), base, offset, index, kind=MoveByte} = Move{moveSize=Move8, source=RegisterArg sourceReg, destination=MemoryArg {base=base, offset=offset, index=index}} | llStoreArgument{ source=RegisterArg(GenReg sourceReg), base, offset, index, kind=Move16Bit} = Move{moveSize=Move16, source=RegisterArg sourceReg, destination=MemoryArg {base=base, offset=offset, index=index}} | llStoreArgument{ source=RegisterArg(GenReg sourceReg), base, offset, index, kind=Move32Bit} = Move{source=RegisterArg sourceReg, destination=MemoryArg {base=base, offset=offset, index=index}, moveSize=opSizeToMove OpSize32} (* Store a short constant to memory *) | llStoreArgument{ source=NonAddressConstArg srcValue, base, offset, index, kind=Move64Bit} = Move{source=NonAddressConstArg srcValue, destination=MemoryArg {base=base, offset=offset, index=index}, moveSize=Move64} | llStoreArgument{ source=NonAddressConstArg srcValue, base, offset, index, kind=Move32Bit} = Move{source=NonAddressConstArg srcValue, destination=MemoryArg {base=base, offset=offset, index=index}, moveSize=Move32} | llStoreArgument{ source=NonAddressConstArg srcValue, base, offset, index, kind=MoveByte} = Move{moveSize=Move8, source=NonAddressConstArg srcValue, destination=MemoryArg{base=base, offset=offset, index=index}} (* Store a long constant to memory *) | llStoreArgument{ source=AddressConstArg srcValue, base, offset, index, kind} = ( (* This Move must be of a polyWord size. *) case (kind, polyWordOpSize) of (Move64Bit, OpSize64) => () | (Move32Bit, OpSize32) => () | _ => raise InternalError "Move of AddressConstArg"; Move{moveSize=opSizeToMove polyWordOpSize, source=AddressConstArg srcValue, destination=MemoryArg {base=base, offset=offset, index=index}} ) (* Store a floating point value. *) | llStoreArgument{source=RegisterArg(FPReg fpReg), offset, base=baseReg, index, kind=MoveDouble} = let val _ = fpReg = fp0 orelse raise InternalError "llStoreArgument: Store FPReg <> fp0" in FPStoreToMemory{ address={ base=baseReg, offset=offset, index=index}, precision=DoublePrecision, andPop=true } end | llStoreArgument{source=RegisterArg(XMMReg xmmRegReg), offset, base=baseReg, index, kind=MoveDouble} = XMMStoreToMemory { toStore=xmmRegReg, address={base=baseReg, offset=offset, index=index}, precision=DoublePrecision } (* Store a floating point value. *) | llStoreArgument{source=RegisterArg(FPReg fpReg), offset, base=baseReg, index, kind=MoveFloat} = let val _ = fpReg = fp0 orelse raise InternalError "llStoreArgument: Store FPReg <> fp0" in FPStoreToMemory{address={ base=baseReg, offset=offset, index=index}, precision=SinglePrecision, andPop=true } end | llStoreArgument{source=RegisterArg(XMMReg xmmRegReg), offset, base=baseReg, index, kind=MoveFloat} = XMMStoreToMemory { toStore=xmmRegReg, address={base=baseReg, offset=offset, index=index}, precision=SinglePrecision } | llStoreArgument _ = raise InternalError "llStoreArgument: StoreArgument" val numBlocks = Vector.length blocks fun getAllocatedReg r = Vector.sub(allocatedRegisters, r) val getAllocatedGenReg = asGenReg o getAllocatedReg and getAllocatedFPReg = asFPReg o getAllocatedReg and getAllocatedXMMReg = asXMMReg o getAllocatedReg fun codeExtIndex NoMemIndex = NoIndex | codeExtIndex(MemIndex1(PReg r)) = Index1(getAllocatedGenReg r) | codeExtIndex(MemIndex2(PReg r)) = Index2(getAllocatedGenReg r) | codeExtIndex(MemIndex4(PReg r)) = Index4(getAllocatedGenReg r) | codeExtIndex(MemIndex8(PReg r)) = Index8(getAllocatedGenReg r) | codeExtIndex ObjectIndex = raise InternalError "codeExtIndex: ObjectIndex" local fun codeExtArgument getReg (RegisterArgument(PReg r)) = RegisterArg(getReg r) | codeExtArgument _ (AddressConstant m) = AddressConstArg m | codeExtArgument _ (IntegerConstant i) = NonAddressConstArg i | codeExtArgument _ (MemoryLocation{base=PReg bReg, offset, index=ObjectIndex, cache=NONE}) = MemoryArg{base=ebx, index=Index4(getAllocatedGenReg bReg), offset=offset} | codeExtArgument _ (MemoryLocation{base=PReg bReg, offset, index, cache=NONE}) = MemoryArg{base=getAllocatedGenReg bReg, offset=offset, index=codeExtIndex index} | codeExtArgument getReg (MemoryLocation{cache=SOME(PReg r), ...}) = RegisterArg(getReg r) | codeExtArgument _ (StackLocation{wordOffset, cache=NONE, ...}) = MemoryArg{base=esp, offset=wordOffset*Word.toInt nativeWordSize, index=NoIndex} | codeExtArgument getReg (StackLocation{cache=SOME(PReg r), ...}) = RegisterArg(getReg r) | codeExtArgument _ (ContainerAddr _) = raise InternalError "codeExtArgument - ContainerAddr" in val codeExtArgument = codeExtArgument getAllocatedReg and codeExtArgumentAsGenReg = codeExtArgument getAllocatedGenReg and codeExtArgumentAsFPReg = codeExtArgument getAllocatedFPReg and codeExtArgumentAsXMMReg = codeExtArgument getAllocatedXMMReg end fun codeCallKind Recursive = NonAddressConstArg 0 (* Jump to the start *) | codeCallKind (ConstantCode v) = AddressConstArg v | codeCallKind FullCall = ( case targetArch of ObjectId32Bit => MemoryArg{base=ebx, index=Index4 edx, offset=0} | _ => MemoryArg{base=edx, index=NoIndex, offset=0} ) (* Move unless the registers are the same. *) fun moveIfNecessary({src, dst, kind}, code) = if src = dst then code else llLoadArgument({source=RegisterArg src, dest=dst, kind=kind}, code) fun opSizeToIMove OpSize64 = Move64Bit | opSizeToIMove OpSize32 = Move32Bit datatype llsource = StackSource of int | OtherSource of reg regOrMemoryArg fun sourceToX86Code(OtherSource r) = r | sourceToX86Code(StackSource wordOffset) = MemoryArg{base=esp, offset=wordOffset*Word.toInt nativeWordSize, index=NoIndex} local fun indexRegister NoIndex = NONE | indexRegister (Index1 r) = SOME r | indexRegister (Index2 r) = SOME r | indexRegister (Index4 r) = SOME r | indexRegister (Index8 r) = SOME r (* The registers are numbered from 0. Choose values that don't conflict with the stack addresses. *) fun regNo r = ~1 - nReg r type node = {src: llsource, dst: destinations } fun nodeAddress({dst=RegDest r, ...}: node) = regNo r | nodeAddress({dst=StackDest a, ...}) = a fun arcs({src=StackSource wordOffset, ...}: node) = [wordOffset] | arcs{src=OtherSource(RegisterArg r), ...} = [regNo r] | arcs{src=OtherSource(MemoryArg{base, index, ...}), ...} = (case indexRegister index of NONE => [regNo(GenReg base)] | SOME r => [regNo(GenReg base), regNo(GenReg r)]) | arcs _ = [] in val stronglyConnected = STRONGLY.stronglyConnectedComponents { nodeAddress=nodeAddress, arcs=arcs } end (* This is a general function for moving values into registers or to the stack where it is possible that the source values might also be in use as destinations. The stack is used for destinations only for tail recursive calls. *) fun moveMultipleValues(moves, workReg: reg option, code) = let val _ = if List.exists(fn {dst=StackDest _, ...} => true | _ => false) moves andalso not(isSome workReg) then raise InternalError "no work reg" else () fun moveValues ([], code) = code (* We're done. *) | moveValues (arguments, code) = let (* stronglyConnectedComponents does two things. It detects loops where it's not possible to move items without breaking the loop but more importantly it orders the dependencies so that if there are no loops we can load the source and store it in the destination knowing that we won't overwrite anything we might later need. *) val ordered = stronglyConnected arguments fun isFPReg(GenReg _) = false | isFPReg(XMMReg _) = true | isFPReg(FPReg _) = true fun moveEachValue ([], code) = code | moveEachValue ([{dst=RegDest reg, src as OtherSource(RegisterArg r)}] :: rest, code) = (* Source and dest are both regs - only move if they're different. *) if r = reg then moveEachValue(rest, code) else moveEachValue(rest, llLoadArgument({source=sourceToX86Code src, dest=reg, kind=if isFPReg reg then MoveDouble else moveNativeWord}, code)) | moveEachValue ([{dst=RegDest reg, src as StackSource _}] :: rest, code) = (* If loading from the stack always use native word. The value could be a stack address. *) moveEachValue(rest, llLoadArgument({source=sourceToX86Code src, dest=reg, kind=moveNativeWord}, code)) | moveEachValue ([{dst=RegDest reg, src}] :: rest, code) = (* Load from store or a constant. Have to use movePolyWord if it's an address constant. *) moveEachValue(rest, llLoadArgument({source=sourceToX86Code src, dest=reg, kind=movePolyWord}, code)) | moveEachValue ([{dst=StackDest _, src=OtherSource(MemoryArg _ )}] :: _, _) = raise InternalError "moveEachValue - MemoryArgument" | moveEachValue ([{dst=StackDest addr, src as StackSource wordOffset}] :: rest, code) = (* Copy a stack location - needs a load and store unless the address is the same. *) if addr = wordOffset then moveEachValue(rest, code) else let val workReg = valOf workReg in moveEachValue(rest, llStoreArgument{source=RegisterArg workReg, base=esp, index=NoIndex, offset = addr*Word.toInt nativeWordSize, kind=moveNativeWord} :: llLoadArgument({source=sourceToX86Code src, dest=workReg, kind=moveNativeWord}, code)) end | moveEachValue ([{dst=StackDest addr, src}] :: rest, code) = (* Store from a register or a constant. *) moveEachValue(rest, llStoreArgument{ source=sourceToX86Code src, base=esp, index=NoIndex, offset = addr*Word.toInt nativeWordSize, kind=moveNativeWord} :: code) | moveEachValue((cycle as first :: _ :: _) :: rest, code) = (* We have a cycle. *) let (* We need to exchange some of the arguments. Doing an exchange here will set the destination with the correct source. However we have to process every subsequent entry with the swapped registers. That may well mean that one of those entries becomes trivial. Using XCHG means that we can move N registers in N-1 exchanges. We also need to rerun stronglyConnectedComponents on at least the rest of this cycle. It's easiest to flatten the rest and do everything. *) (* Try to find either a register-register move or a register-stack move. If not use the first. If there's a stack-register move there will also be a register-stack so we don't need to look for both. *) val {dst=selectDst, src=selectSrc} = case List.find(fn {src=OtherSource(RegisterArg _), dst=RegDest _} => true | _ => false) cycle of SOME found => found | _ => ( case List.find(fn {dst=RegDest _, ...} => true | _ => false) cycle of SOME found => found | NONE => first ) (* This includes this entry but after the swap we'll eliminate it. *) val flattened = List.foldl(fn (a, b) => a @ b) [] (cycle :: rest) val destAsSource = case selectDst of RegDest reg => OtherSource(RegisterArg reg) | StackDest s => StackSource s (* Source is not an equality type. We can't currently handle the situation where the source is a memory location. *) fun match(OtherSource(RegisterArg r1), OtherSource(RegisterArg r2)) = r1 = r2 | match(StackSource s1, StackSource s2) = s1 = s2 | match(OtherSource(MemoryArg _), _) = raise InternalError "moveEachValue: cycle" | match _ = false fun swapSources{src, dst} = if match(src, selectSrc) then {src=destAsSource, dst=dst} else if match(src, destAsSource) then {src=selectSrc, dst=dst} else {src=src, dst=dst} (* Try to use register to register exchange if we can. A register-to-memory exchange involves a bus lock and we'd like to avoid that. *) val exchangeCode = case (selectDst, selectSrc) of (RegDest(GenReg regA), OtherSource(RegisterArg(GenReg regB))) => XChng { reg=regA, arg=RegisterArg regB, opSize=nativeWordOpSize } :: code | (RegDest(XMMReg regA), OtherSource(RegisterArg(XMMReg regB))) => (* This is the only case where we can have a cycle with SSE2 regs. There are various ways of doing it but XORs are probably the easiest. *) XMMArith{opc=SSE2Xor, source=RegisterArg regA, output=regB} :: XMMArith{opc=SSE2Xor, source=RegisterArg regB, output=regA} :: XMMArith{opc=SSE2Xor, source=RegisterArg regA, output=regB} :: code | (RegDest _, OtherSource(RegisterArg _)) => raise InternalError "moveEachValue: invalid register combination" | (RegDest regA, src as StackSource addr) => let val workReg = valOf workReg in llStoreArgument{source=RegisterArg workReg, base=esp, index=NoIndex, offset = addr*Word.toInt nativeWordSize, kind=moveNativeWord} :: XChng { reg=asGenReg regA, arg=RegisterArg(asGenReg workReg), opSize=nativeWordOpSize } :: llLoadArgument({source=sourceToX86Code src, dest=workReg, kind=moveNativeWord}, code) end | (StackDest addr, OtherSource(RegisterArg regA)) => let (* This doesn't actually occur because we always find the case above. *) val workReg = valOf workReg in llStoreArgument{source=RegisterArg workReg, base=esp, index=NoIndex, offset = addr*Word.toInt nativeWordSize, kind=moveNativeWord} :: XChng { reg=asGenReg regA, arg=RegisterArg (asGenReg workReg), opSize=nativeWordOpSize } :: llLoadArgument({ source=MemoryArg{base=esp, offset=addr*Word.toInt nativeWordSize, index=NoIndex}, dest=workReg, kind=moveNativeWord}, code) end | (StackDest addr1, StackSource addr2) => let val workReg = valOf workReg (* This can still happen if we have argument registers that need to be loaded from stack locations and those argument registers happen to contain the values to be stored into those stack locations. e.g. ebx => S8; eax => S7; S8 => eax; S7 => eax. Eliminating the registers results in a cycle. It may be possible to avoid this by excluding the argument registers (eax; ebx; r8; r9; r10) from holding values in the area to be overwritten. *) in llStoreArgument{source=RegisterArg workReg, base=esp, index=NoIndex, offset = addr1*Word.toInt nativeWordSize, kind=moveNativeWord} :: XChng { reg=asGenReg workReg, arg=MemoryArg{base=esp, offset=addr2*Word.toInt nativeWordSize, index=NoIndex}, opSize=nativeWordOpSize } :: llLoadArgument({ source=MemoryArg{base=esp, offset=addr1*Word.toInt nativeWordSize, index=NoIndex}, dest=workReg, kind=moveNativeWord}, code) end | _ => raise InternalError "moveEachValue: cycle" in moveValues(List.map swapSources flattened, exchangeCode) end | moveEachValue(([]) :: _, _) = (* This should not happen - avoid warning. *) raise InternalError "moveEachValue - empty set" in moveEachValue(ordered, code) end in moveValues(moves, code) end (* Where we have multiple specific registers as either source or destination there is the potential that a destination register if currently in use as a source. *) fun moveMultipleRegisters(regPairList, code) = let val regPairsAsDests = List.map(fn {src, dst} => {src=OtherSource(RegisterArg src), dst=RegDest dst}) regPairList in moveMultipleValues(regPairsAsDests, NONE, code) end val outputLabelCount = ref 0 val blockToLabelMap = Array.array(numBlocks, ~1) fun makeLabel() = Label{labelNo = ! outputLabelCount} before outputLabelCount := !outputLabelCount + 1 fun getBlockLabel blockNo = case Array.sub(blockToLabelMap, blockNo) of ~1 => let val label as Label{labelNo} = makeLabel() val () = Array.update(blockToLabelMap, blockNo, labelNo) in label end | n => Label{labelNo=n} (* The profile object is a single mutable with the F_bytes bit set. *) local val v = RunCall.allocateByteMemory(0w1, Word.fromLargeWord(Word8.toLargeWord(Word8.orb(F_mutable, F_bytes)))) fun clear 0w0 = () | clear i = (assignByte(v, i-0w1, 0w0); clear (i-0w1)) val () = clear wordSize in val profileObject = toMachineWord v end (* Switch to indicate if we want to trace where live data has been allocated. *) val addAllocatingFunction = DEBUG.getParameter DEBUG.profileAllocationTag debugSwitches = 1 fun llAllocateMemoryOperation ({ size, flags, dest, saveRegs}, code) = let val toReg = asGenReg dest val preserve = saveRegs (* Allocate memory. N.B. Instructions are in reverse order. *) fun allocStore{size, flags, output, preserve} = if targetArch = Native64Bit andalso flags <> 0w0 then [Move{moveSize=Move8, source=NonAddressConstArg(Word8.toLargeInt flags), destination=MemoryArg {offset= ~1, base=output, index=NoIndex}}, Move{source=NonAddressConstArg(LargeInt.fromInt size), destination=MemoryArg {offset= ~ (Word.toInt wordSize), base=output, index=NoIndex}, moveSize=opSizeToMove polyWordOpSize}, AllocStore{size=size, output=output, saveRegs=preserve}] else let val lengthWord = IntInf.orb(IntInf.fromInt size, IntInf.<<(Word8.toLargeInt flags, 0w24)) in [Move{source=NonAddressConstArg lengthWord, destination=MemoryArg {offset= ~ (Word.toInt wordSize), base=output, index=NoIndex}, moveSize=opSizeToMove polyWordOpSize}, AllocStore{size=size, output=output, saveRegs=preserve}] end val allocCode = (* If we need to add the profile object *) if addAllocatingFunction then allocStore {size=size+1, flags=Word8.orb(flags, Address.F_profile), output=toReg, preserve=preserve} @ [Move{moveSize=opSizeToMove polyWordOpSize, source=AddressConstArg profileObject, destination=MemoryArg {base=toReg, offset=size*Word.toInt wordSize, index=NoIndex}}] else allocStore {size=size, flags=flags, output=toReg, preserve=preserve} (* Convert to an object index if necessary. *) val convertToObjId = if targetArch = ObjectId32Bit then [ ShiftConstant{ shiftType=SHR, output=toReg, shift=0w2, opSize=OpSize64 }, ArithToGenReg{ opc=SUB, output=toReg, source=RegisterArg ebx, opSize=nativeWordOpSize } ] else [] in convertToObjId @ allocCode @ code end (* Check the stack limit "register". This is used both at the start of a function for genuine stack checking but also in a loop to check for an interrupt. We need to save the registers even across an interrupt because it can be used if another thread wants a GC. *) fun testRegAndTrap(reg, entryPt, saveRegs) = let (* Normally we won't have a stack overflow so we will skip the check. *) val skipCheckLab = makeLabel() in (* Need it in reverse order. *) [ JumpLabel skipCheckLab, CallRTS{rtsEntry=entryPt, saveRegs=saveRegs}, ConditionalBranch{test=JNB, label=skipCheckLab}, ArithToGenReg{ opc=CMP, output=reg, source=MemoryArg{offset=memRegStackLimit, base=ebp, index=NoIndex}, opSize=nativeWordOpSize } ] end local val numRegisters = Vector.length allocatedRegisters val uses = Array.array(numRegisters, false) fun used(PReg r) = Array.update(uses, r, true) fun isUsed(PReg r) = Array.sub(uses, r) (* Set the registers used by the sources. This differs from getInstructionState in that we don't set the base register of a memory location to "used" if we can use the cache. *) fun argUses(RegisterArgument rarg) = used rarg | argUses(MemoryLocation { cache=SOME cr, ...}) = used cr | argUses(MemoryLocation { base, index, cache=NONE, ...}) = (used base; indexUses index) | argUses(StackLocation { cache=SOME rarg, ...}) = used rarg | argUses _ = () and indexUses NoMemIndex = () | indexUses(MemIndex1 arg) = used arg | indexUses(MemIndex2 arg) = used arg | indexUses(MemIndex4 arg) = used arg | indexUses(MemIndex8 arg) = used arg | indexUses ObjectIndex = () (* LoadArgument, TagValue, CopyToCache, UntagValue and BoxValue are eliminated if their destination is not used. In that case their source are not used either. *) fun instructionUses(LoadArgument { source, dest, ...}) = if isUsed dest then argUses source else () | instructionUses(StoreArgument{ source, base, index, ...}) = (argUses source; used base; indexUses index) | instructionUses(LoadMemReg _) = () | instructionUses(StoreMemReg {source, ...}) = used source | instructionUses(BeginFunction _) = () | instructionUses(FunctionCall{regArgs, stackArgs, ...}) = (List.app(argUses o #1) regArgs; List.app argUses stackArgs) | instructionUses(TailRecursiveCall{regArgs, stackArgs, ...}) = (List.app(argUses o #1) regArgs; List.app(argUses o #src) stackArgs) | instructionUses(AllocateMemoryOperation _) = () | instructionUses(AllocateMemoryVariable{size, ...}) = used size | instructionUses(InitialiseMem{size, addr, init}) = (used size; used addr; used init) | instructionUses(InitialisationComplete) = () | instructionUses(BeginLoop) = () | instructionUses(JumpLoop{regArgs, stackArgs, ...}) = (List.app(argUses o #1) regArgs; List.app(argUses o #1) stackArgs) | instructionUses(RaiseExceptionPacket{packetReg}) = used packetReg | instructionUses(ReserveContainer _) = () | instructionUses(IndexedCaseOperation{testReg, ...}) = used testReg | instructionUses(LockMutable{addr}) = used addr | instructionUses(WordComparison{arg1, arg2, ...}) = (used arg1; argUses arg2) | instructionUses(CompareLiteral{arg1, ...}) = argUses arg1 | instructionUses(CompareByteMem{arg1={base, index, ...}, ...}) = (used base; indexUses index) | instructionUses(PushExceptionHandler _) = () | instructionUses(PopExceptionHandler _) = () | instructionUses(BeginHandler _) = () | instructionUses(ReturnResultFromFunction{resultReg, ...}) = used resultReg | instructionUses(ArithmeticFunction{operand1, operand2, ...}) = (used operand1; argUses operand2) | instructionUses(TestTagBit{arg, ...}) = argUses arg | instructionUses(PushValue {arg, ...}) = argUses arg | instructionUses(CopyToCache{source, dest, ...}) = if isUsed dest then used source else () | instructionUses(ResetStackPtr _) = () | instructionUses(StoreToStack {source, ...}) = argUses source | instructionUses(TagValue{source, dest, ...}) = if isUsed dest then used source else () | instructionUses(UntagValue{dest, cache=SOME cacheR, ...}) = if isUsed dest then used cacheR else () | instructionUses(UntagValue{source, dest, cache=NONE, ...}) = if isUsed dest then used source else () | instructionUses(LoadEffectiveAddress{base, index, ...}) = (case base of SOME bReg => used bReg | NONE => (); indexUses index) | instructionUses(ShiftOperation{operand, shiftAmount, ...}) = (used operand; argUses shiftAmount) | instructionUses(Multiplication{operand1, operand2, ...}) = (used operand1; argUses operand2) | instructionUses(Division{dividend, divisor, ...}) = (used dividend; argUses divisor) | instructionUses(AtomicExchangeAndAdd{base, source}) = (used base; used source) | instructionUses(BoxValue{source, dest, ...}) = if isUsed dest then used source else () | instructionUses(CompareByteVectors{vec1Addr, vec2Addr, length, ...}) = (used vec1Addr; used vec2Addr; used length) | instructionUses(BlockMove{srcAddr, destAddr, length, ...}) = (used srcAddr; used destAddr; used length) | instructionUses(X87Compare{arg1, arg2, ...}) = (used arg1; argUses arg2) | instructionUses(SSE2Compare{arg1, arg2, ...}) = (used arg1; argUses arg2) | instructionUses(X87FPGetCondition _) = () | instructionUses(X87FPArith{arg1, arg2, ...}) = (used arg1; argUses arg2) | instructionUses(X87FPUnaryOps{source, ...}) = used source | instructionUses(X87Float{source, ...}) = argUses source | instructionUses(SSE2Float{source, ...}) = argUses source | instructionUses(SSE2FPUnary{source, ...}) = argUses source | instructionUses(SSE2FPBinary{arg1, arg2, ...}) = (used arg1; argUses arg2) | instructionUses(TagFloat{source, dest, ...}) = if isUsed dest then used source else () | instructionUses(UntagFloat{dest, cache=SOME cacheR, ...}) = if isUsed dest then used cacheR else () | instructionUses(UntagFloat{source, dest, cache=NONE, ...}) = if isUsed dest then argUses source else () | instructionUses(GetSSE2ControlReg _) = () | instructionUses(SetSSE2ControlReg{source}) = used source | instructionUses(GetX87ControlReg _) = () | instructionUses(SetX87ControlReg{source}) = used source | instructionUses(X87RealToInt{source, ...}) = used source | instructionUses(SSE2RealToInt{source, ...}) = argUses source | instructionUses(SignExtend32To64{source, dest}) = if isUsed dest then argUses source else () | instructionUses(TouchArgument{source}) = used source (* Depth-first scan. *) val visited = Array.array(numBlocks, false) fun processBlocks blockNo = if Array.sub(visited, blockNo) then () (* Done or currently being done. *) else let val () = Array.update(visited, blockNo, true) val ExtendedBasicBlock { flow, block,...} = Vector.sub(blocks, blockNo) val () = (* Process the dependencies first. *) case flow of ExitCode => () | Unconditional m => processBlocks m | Conditional {trueJump, falseJump, ...} => (processBlocks trueJump; processBlocks falseJump) | IndexedBr cases => List.app processBlocks cases | SetHandler{ handler, continue } => (processBlocks handler; processBlocks continue) | UnconditionalHandle _ => () | ConditionalHandle { continue, ...} => processBlocks continue (* Now this block. *) in List.foldr(fn ({instr, ...}, ()) => instructionUses instr) () block end in val () = processBlocks 0 val isUsed = isUsed end (* Return the register part of a cached item. *) fun decache(StackLocation{cache=SOME r, ...}) = RegisterArgument r | decache(MemoryLocation{cache=SOME r, ...}) = RegisterArgument r | decache arg = arg (* Only get the registers that are actually used. *) val getSaveRegs = List.mapPartial(fn (reg as PReg r) => if isUsed reg then SOME(getAllocatedGenReg r) else NONE) fun codeExtended _ ({instr=LoadArgument{source, dest as PReg dreg, kind}, ...}, code) = if not (isUsed dest) then code else let val realDestReg = getAllocatedReg dreg in case source of RegisterArgument(PReg sreg) => (* Register to register move. Try to use the same register for the source as the destination to eliminate the instruction. *) (* If the source is the same as the destination we don't need to do anything. *) moveIfNecessary({src=getAllocatedReg sreg, dst=realDestReg, kind=kind}, code) | MemoryLocation{cache=SOME(PReg sreg), ...} => (* This is also a register to register move but because the original load is from memory it could be a byte or short precision value. *) let val moveKind = case kind of Move64Bit => Move64Bit | MoveByte => Move32Bit | Move16Bit => Move32Bit | Move32Bit => Move32Bit | MoveFloat => MoveFloat | MoveDouble => MoveDouble in moveIfNecessary({src=getAllocatedReg sreg, dst=realDestReg, kind=moveKind}, code) end (* TODO: Isn't this covered by codeExtArgument? It looks like it was added in the 32-in-64 changes. *) | StackLocation{cache=SOME(PReg sreg), ...} => moveIfNecessary({src=getAllocatedReg sreg, dst=realDestReg, kind=kind}, code) | source as StackLocation _ => (* Always use native loads from the stack. *) llLoadArgument({source=codeExtArgument source, dest=realDestReg, kind=moveNativeWord}, code) | source => (* Loads of constants or from an address. *) llLoadArgument({source=codeExtArgument source, dest=realDestReg, kind=kind}, code) end | codeExtended _ ({instr=StoreArgument{ source, base=PReg bReg, offset, index, kind, ... }, ...}, code) = let val (baseReg, indexVal) = case index of ObjectIndex => (ebx, Index4(getAllocatedGenReg bReg)) | _ => (getAllocatedGenReg bReg, codeExtIndex index) in case (decache source, kind) of (RegisterArgument(PReg sReg), MoveByte) => if targetArch <> Native32Bit then llStoreArgument{ source=codeExtArgument source, base=baseReg, offset=offset, index=indexVal, kind=MoveByte} :: code else (* This is complicated on X86/32. We can't use edi or esi for the store registers. Instead we reserve ecx (see special case in "identify") and use that if we have to. *) let val realStoreReg = getAllocatedReg sReg val (moveCode, storeReg) = if realStoreReg = GenReg edi orelse realStoreReg = GenReg esi then (moveIfNecessary({src=realStoreReg, dst=GenReg ecx, kind=moveNativeWord}, code), GenReg ecx) else (code, realStoreReg) in llStoreArgument{ source=RegisterArg storeReg, base=baseReg, offset=offset, index=indexVal, kind=MoveByte} :: moveCode end | _ => llStoreArgument{ source=codeExtArgument source, base=baseReg, offset=offset, index=indexVal, kind=kind} :: code end | codeExtended _ ({instr=LoadMemReg { offset, dest=PReg pr, kind}, ...}, code) = (* Load from the "memory registers" pointed at by rbp. *) llLoadArgument({source=MemoryArg{base=rbp, offset=offset, index=NoIndex}, dest=getAllocatedReg pr, kind=kind}, code) | codeExtended _ ({instr=StoreMemReg { offset, source=PReg pr, kind}, ...}, code) = (* Store into the "memory register". *) llStoreArgument{ source=RegisterArg(getAllocatedReg pr), base=rbp, offset=offset, index=NoIndex, kind=kind} :: code | codeExtended _ ({instr=BeginFunction{regArgs, ...}, ...}, code) = let val minStackCheck = 20 val saveRegs = List.mapPartial(fn (_, GenReg r) => SOME r | _ => NONE) regArgs val preludeCode = if stackRequired >= minStackCheck then let (* Compute the necessary amount in edi and compare that. *) val stackByteAdjust = ~ (Word.toInt nativeWordSize) * stackRequired val testEdiCode = testRegAndTrap (edi, StackOverflowCallEx, saveRegs) in (* N.B. In reverse order. *) testEdiCode @ [LoadAddress{output=edi, base=SOME esp, index=NoIndex, offset=stackByteAdjust, opSize=nativeWordOpSize}] end else testRegAndTrap (esp, StackOverflowCall, saveRegs) val usedRegs = List.filter (isUsed o #1) regArgs fun mkPair(PReg pr, rr) = {src=rr,dst=getAllocatedReg pr} val regPairs = List.map mkPair usedRegs in moveMultipleRegisters(regPairs, preludeCode @ code) end | codeExtended _ ({instr=TailRecursiveCall{callKind, regArgs=oRegArgs, stackArgs=oStackArgs, stackAdjust, currStackSize, workReg=PReg wReg}, ...}, code) = let val regArgs = List.map (fn (arg, reg) => (decache arg, reg)) oRegArgs and stackArgs = List.map(fn {src, stack } => {src=decache src, stack=stack}) oStackArgs val workReg = getAllocatedReg wReg (* We must leave stack entries as stack entries for the moment. *) fun codeArg(StackLocation{wordOffset, cache=NONE, ...}) = StackSource wordOffset | codeArg arg = OtherSource(codeExtArgument arg) val extStackArgs = map (fn {stack, src} => {dst=StackDest(stack+currStackSize), src=codeArg src}) stackArgs val extRegArgs = map (fn (a, r) => {src=codeArg a, dst=RegDest r}) regArgs (* Tail recursive calls are complicated because we generally have to overwrite the existing stack. That means storing the arguments in the right order to avoid overwriting a value that we are using for a different argument. *) fun codeTailCall(arguments: {dst: destinations, src: llsource} list, stackAdjust, code) = if stackAdjust < 0 then let (* If the function we're calling takes more arguments on the stack than the current function we will have to extend the stack. Do that by pushing the argument whose offset is at -1. Then adjust all the offsets and repeat. *) val {src=argM1, ...} = valOf(List.find(fn {dst=StackDest ~1, ...} => true | _ => false) arguments) fun renumberArgs [] = [] | renumberArgs ({dst=StackDest ~1, ...} :: args) = renumberArgs args (* Remove the one we've done. *) | renumberArgs ({dst, src} :: args) = let val newDest = case dst of StackDest d => StackDest(d+1) | regDest => regDest val newSrc = case src of StackSource wordOffset => StackSource(wordOffset+1) | other => other in {dst=newDest, src=newSrc} :: renumberArgs args end in codeTailCall(renumberArgs arguments, stackAdjust+1, PushToStack(sourceAsGenRegOrMem(sourceToX86Code argM1)) :: code) end else let val loadArgs = moveMultipleValues(arguments, SOME workReg, code) in if stackAdjust = 0 then loadArgs else ResetStack{numWords=stackAdjust, preserveCC=false} :: loadArgs end in JumpAddress(codeCallKind callKind) :: codeTailCall(extStackArgs @ extRegArgs, stackAdjust+currStackSize, code) end | codeExtended _ ({instr=FunctionCall{callKind, regArgs=oRegArgs, stackArgs=oStackArgs, dest=PReg dReg, realDest, saveRegs}, ...}, code) = let val regArgs = List.map (fn (arg, reg) => (decache arg, reg)) oRegArgs and stackArgs = List.map decache oStackArgs val destReg = getAllocatedReg dReg fun pushStackArgs ([], _, code) = code | pushStackArgs (ContainerAddr {stackOffset, ...} ::args, argNum, code) = let val adjustedAddr = stackOffset+argNum (* If there is an offset relative to rsp we need to add this in. *) val addOffset = if adjustedAddr = 0 then [] else [ArithMemConst{opc=ADD, address={offset=0, base=esp, index=NoIndex}, source=LargeInt.fromInt(adjustedAddr*Word.toInt nativeWordSize), opSize=nativeWordOpSize}] in pushStackArgs(args, argNum+1, addOffset @ PushToStack(RegisterArg esp) :: code) end | pushStackArgs (StackLocation {wordOffset, container, field, ...} ::args, argNum, code) = let (* Have to adjust the offsets of stack arguments. *) val adjusted = StackLocation{wordOffset=wordOffset+argNum, container=container, field=field+argNum, cache=NONE} in pushStackArgs(args, argNum+1, PushToStack(codeExtArgumentAsGenReg adjusted) :: code) end | pushStackArgs (arg::args, argNum, code) = pushStackArgs(args, argNum+1, PushToStack(codeExtArgumentAsGenReg arg) :: code) val pushedArgs = pushStackArgs(stackArgs, 0, code (* Initial code *)) (* We have to adjust any stack offset to account for the arguments we've pushed. *) val numStackArgs = List.length stackArgs (* We don't currently allow the arguments to be memory locations and instead force them into registers. That may be simpler especially if we can get the values directly into the required register. *) fun getRegArgs(RegisterArgument(PReg pr), reg) = SOME{dst=reg, src=getAllocatedReg pr} | getRegArgs(StackLocation {cache=SOME(PReg pr), ...}, reg) = SOME{dst=reg, src=getAllocatedReg pr} | getRegArgs(MemoryLocation _, _) = raise InternalError "FunctionCall - MemoryLocation" | getRegArgs _ = NONE val loadRegArgs = moveMultipleRegisters(List.mapPartial getRegArgs regArgs, pushedArgs) (* These are all items we can load without requiring a source register. That includes loading from the stack. *) fun getConstArgs((AddressConstant m, reg), code) = llLoadArgument({source=AddressConstArg m, dest=reg, kind=movePolyWord}, code) | getConstArgs((IntegerConstant i, reg), code) = llLoadArgument({source=NonAddressConstArg i, dest=reg, kind=movePolyWord}, code) | getConstArgs((StackLocation { cache=SOME _, ...}, _), code) = code | getConstArgs((StackLocation { wordOffset, ...}, reg), code) = llLoadArgument({source=MemoryArg{offset=(wordOffset+numStackArgs)*Word.toInt nativeWordSize, base=esp, index=NoIndex}, dest=reg, kind=moveNativeWord}, code) | getConstArgs((ContainerAddr {stackOffset, ...}, reg), code) = if stackOffset+numStackArgs = 0 then llLoadArgument({source=RegisterArg(GenReg esp), dest=reg, kind=moveNativeWord}, code) else LoadAddress{ output=asGenReg reg, offset=(stackOffset+numStackArgs)*Word.toInt nativeWordSize, base=SOME esp, index=NoIndex, opSize=nativeWordOpSize } :: code | getConstArgs((RegisterArgument _, _), code) = code | getConstArgs((MemoryLocation _, _), code) = code val loadConstArgs = List.foldl getConstArgs loadRegArgs regArgs (* Push the registers before the call and pop them afterwards. *) fun makeSaves([], code) = CallAddress(codeCallKind callKind) :: code | makeSaves(PReg reg::regs, code) = let val areg = getAllocatedGenReg reg val _ = areg = eax andalso raise InternalError "codeExtended: eax in save regs" val _ = if List.exists(fn (_, r) => r = GenReg areg) regArgs then raise InternalError "codeExtended: arg reg in save regs" else () in PopR areg :: makeSaves(regs, PushToStack(RegisterArg areg) :: code) end in moveIfNecessary({dst=destReg, src=realDest, kind=case realDest of GenReg _ => moveNativeWord | _ => MoveDouble}, makeSaves(saveRegs, loadConstArgs)) end | codeExtended _ ({instr=AllocateMemoryOperation{ size, flags, dest=PReg dReg, saveRegs}, ...}, code) = let val preserve = getSaveRegs saveRegs in llAllocateMemoryOperation({ size=size, flags=flags, dest=getAllocatedReg dReg, saveRegs=preserve}, code) end | codeExtended _ ({instr=AllocateMemoryVariable{size=PReg size, dest=PReg dest, saveRegs}, ...}, code) = let (* Simple case - no initialiser. *) val saveRegs = getSaveRegs saveRegs val sReg = getAllocatedGenReg size and dReg = getAllocatedGenReg dest val _ = sReg <> dReg orelse raise InternalError "codeGenICode-AllocateMemoryVariable" val allocCode = [ (* Store it as the length field. *) Move{source=RegisterArg sReg, moveSize=opSizeToMove polyWordOpSize, destination=MemoryArg {base=dReg, offset= ~ (Word.toInt wordSize), index=NoIndex}}, (* Untag the length *) ShiftConstant{ shiftType=SHR, output=sReg, shift=0w1, opSize=polyWordOpSize}, (* Allocate the memory *) AllocStoreVariable{ size=sReg, output=dReg, saveRegs=saveRegs} ] (* Convert to an object index if necessary. *) val convertToObjId = if targetArch = ObjectId32Bit then [ ShiftConstant{ shiftType=SHR, output=dReg, shift=0w2, opSize=OpSize64 }, ArithToGenReg{ opc=SUB, output=dReg, source=RegisterArg ebx, opSize=nativeWordOpSize } ] else [] in convertToObjId @ allocCode @ code end | codeExtended _ ({instr=InitialiseMem{size=PReg sReg, addr=PReg aReg, init=PReg iReg}, ...}, code) = (* We are going to use rep stosl/q to set the memory. That requires the length to be in ecx, the initialiser to be in eax and the destination to be edi. *) RepeatOperation (if polyWordOpSize = OpSize64 then STOS64 else STOS32):: moveIfNecessary({src=getAllocatedReg iReg, dst=GenReg eax, kind=moveNativeWord}, moveIfNecessary({src=getAllocatedReg aReg, dst=GenReg edi, kind=moveNativeWord}, moveIfNecessary({src=getAllocatedReg sReg, dst=GenReg ecx, kind=moveNativeWord}, code))) | codeExtended _ ({instr=InitialisationComplete, ...}, code) = StoreInitialised :: code | codeExtended _ ({instr=BeginLoop, ...}, code) = code | codeExtended _ ({instr=JumpLoop{regArgs, stackArgs, checkInterrupt, workReg}, ...}, code) = let val workReg = Option.map (fn PReg r => getAllocatedReg r) workReg (* TODO: Make the sources and destinations "friends". *) (* We must leave stack entries as stack entries for the moment as with TailCall. *) fun codeArg(StackLocation{wordOffset, ...}) = StackSource wordOffset | codeArg arg = OtherSource(codeExtArgument arg) val extStackArgs = map (fn (src, stack, _) => {dst=StackDest stack, src=codeArg src}) stackArgs val extRegArgs = map (fn (a, PReg r) => {src=codeArg a, dst=RegDest(getAllocatedReg r)}) regArgs val checkCode = case checkInterrupt of NONE => [] | SOME saveRegs => testRegAndTrap (esp, StackOverflowCall, getSaveRegs saveRegs) in checkCode @ moveMultipleValues(extStackArgs @ extRegArgs, workReg, code) end | codeExtended _ ({instr=RaiseExceptionPacket{ packetReg=PReg preg }, ...}, code) = (* We need a work register here. It can be any register other than eax since we don't preserve registers across calls. *) RaiseException { workReg=ecx } :: moveIfNecessary({src=getAllocatedReg preg, dst=GenReg eax, kind=moveNativeWord}, code) | codeExtended _ ({instr=ReserveContainer{size, ...}, ...}, code) = (* The memory must be cleared in case we have a GC. *) List.tabulate(size, fn _ => PushToStack(NonAddressConstArg(tag 0))) @ code | codeExtended {flow} ({instr=IndexedCaseOperation{testReg=PReg tReg, workReg=PReg wReg}, ...}, code) = let val testReg = getAllocatedReg tReg val workReg = getAllocatedReg wReg val _ = testReg <> workReg orelse raise InternalError "IndexedCaseOperation - same registers" val rReg = asGenReg testReg and wReg = asGenReg workReg val _ = rReg <> wReg orelse raise InternalError "IndexedCaseOperation - same registers" (* This should only be within a block with an IndexedBr flow type. *) val cases = case flow of IndexedBr cases => cases | _ => raise InternalError "codeGenICode: IndexedCaseOperation" val caseLabels = map getBlockLabel cases val startJumpTable = makeLabel() (* Compute the jump address. The index is a tagged integer so it is already multiplied by 2. We need to multiply by four to get the correct size. Subtract off the shifted tag. *) val jumpSize = ref JumpSize8 in JumpTable{cases=caseLabels, jumpSize=jumpSize} :: JumpLabel startJumpTable :: JumpAddress(RegisterArg wReg) :: IndexedJumpCalc{ addrReg=wReg, indexReg=rReg, jumpSize=jumpSize } :: LoadLabelAddress{label=startJumpTable, output=wReg} :: code end | codeExtended _ ({instr=LockMutable{addr=PReg pr}, ...}, code) = let val (bReg, index) = if targetArch = ObjectId32Bit then (ebx, Index4(asGenReg(getAllocatedReg pr))) else (asGenReg(getAllocatedReg pr), NoIndex) in (* Mask off the mutable bit. *) ArithByteMemConst{opc=AND, address={base=bReg, offset= ~1, index=index}, source=0wxff - F_mutable} :: code end | codeExtended _ ({instr=WordComparison{ arg1=PReg pr, arg2, opSize, ... }, ...}, code) = ArithToGenReg {opc=CMP, output=asGenReg(getAllocatedReg pr), source=codeExtArgumentAsGenReg arg2, opSize=opSize} :: code | codeExtended _ ({instr=CompareLiteral{ arg1, arg2, opSize, ... }, ...}, code) = ( case decache arg1 of (* N.B. We MUST decache since we're assuming that the base reg is not used. *) RegisterArgument(PReg pr) => ArithToGenReg {opc=CMP, output=asGenReg(getAllocatedReg pr), source=NonAddressConstArg arg2, opSize=opSize} :: code | MemoryLocation{base=PReg br, offset, index=ObjectIndex, ...} => ArithMemConst{ opc=CMP, address={offset=offset, base=ebx, index=Index4(asGenReg(getAllocatedReg br))}, source=arg2, opSize=opSize } :: code | MemoryLocation{base=PReg br, index, offset, ...} => ArithMemConst{ opc=CMP, address={offset=offset, base=asGenReg(getAllocatedReg br), index=codeExtIndex index}, source=arg2, opSize=opSize } :: code | StackLocation{wordOffset, ...} => ArithMemConst{ opc=CMP, address={offset=wordOffset*Word.toInt nativeWordSize, base=esp, index=NoIndex}, source=arg2, opSize=opSize } :: code | _ => raise InternalError "CompareLiteral" ) | codeExtended _ ({instr=CompareByteMem{ arg1={base=PReg br, offset, index}, arg2, ... }, ...}, code) = let val (bReg, index) = case index of ObjectIndex => (ebx, Index4(asGenReg(getAllocatedReg br))) | _ => (asGenReg(getAllocatedReg br), codeExtIndex index) in ArithByteMemConst{ opc=CMP, address={offset=offset, base=bReg, index=index}, source=arg2 } :: code end (* Set up an exception handler. *) | codeExtended {flow} ({instr=PushExceptionHandler{workReg=PReg hReg}, ...}, code) = let (* Set up an exception handler. *) val workReg=getAllocatedReg hReg (* Although we're pushing this to the stack we need to use LEA on the X86/64 and some arithmetic on the X86/32. We need a work reg for that. *) val handleReg = asGenReg workReg (* This should only be within a block with a SetHandler flow type. *) val handleLabel = case flow of SetHandler{ handler, ...} => handler | _ => raise InternalError "codeGenICode: PushExceptionHandler" val labelRef = getBlockLabel handleLabel (* Set up the handler by pushing the old handler to the stack, pushing the entry point and setting the handler address to the current stack pointer. *) in ( Move{source=RegisterArg esp, destination=MemoryArg {offset=memRegHandlerRegister, base=ebp, index=NoIndex}, moveSize=opSizeToMove nativeWordOpSize} :: PushToStack(RegisterArg handleReg) :: LoadLabelAddress{ label=labelRef, output=handleReg} :: PushToStack(MemoryArg{base=ebp, offset=memRegHandlerRegister, index=NoIndex}) :: code) end (* Pop an exception handler at the end of a handled section. Executed if no exception has been raised. This removes items from the stack. *) | codeExtended _ ({instr=PopExceptionHandler{workReg=PReg wReg, ...}, ...}, code) = let val workReg = getAllocatedReg wReg val wReg = asGenReg workReg in (* The stack pointer has been adjusted to just above the two words that were stored in PushExceptionHandler. *) ( Move{source=RegisterArg wReg, destination=MemoryArg {offset=memRegHandlerRegister, base=ebp, index=NoIndex}, moveSize=opSizeToMove nativeWordOpSize} :: PopR wReg :: ResetStack{numWords=1, preserveCC=false} :: code) end (* Start of a handler. Sets the address associated with PushExceptionHandler and provides a register for the packet.*) | codeExtended _ ({instr=BeginHandler{packetReg=PReg pReg, workReg=PReg wReg}, ...}, code) = let (* The exception packet is in rax. *) val realPktReg = getAllocatedReg pReg val realWorkreg = getAllocatedGenReg wReg (* The code here is almost the same as PopExceptionHandler. The only real difference is that PopExceptionHandler needs to pass the result of executing the handled code which could be in any register. This code needs to transmit the exception packet and that is always in rax. *) val beginHandleCode = Move{source=RegisterArg realWorkreg, destination=MemoryArg {offset=memRegHandlerRegister, base=ebp, index=NoIndex}, moveSize=opSizeToMove nativeWordOpSize} :: PopR realWorkreg :: ResetStack{numWords=1, preserveCC=false} :: Move{ source=MemoryArg{base=ebp, offset=memRegHandlerRegister, index=NoIndex}, destination=RegisterArg esp, moveSize=opSizeToMove nativeWordOpSize } :: code in moveIfNecessary({src=GenReg eax, dst=realPktReg, kind=moveNativeWord }, beginHandleCode) end | codeExtended _ ({instr=ReturnResultFromFunction { resultReg=PReg resReg, realReg, numStackArgs }, ...}, code) = let val resultReg = getAllocatedReg resReg (* If for some reason it's not in the right register we have to move it there. *) in ReturnFromFunction numStackArgs :: moveIfNecessary({src=resultReg, dst=realReg, kind=moveNativeWord}, code) end | codeExtended _ ({instr=ArithmeticFunction{oper=SUB, resultReg=PReg resReg, operand1=PReg op1Reg, operand2, opSize, ...}, ...}, code) = (* Subtraction - this is special because it can only be done one way round. The first argument must be in a register. *) let val realDestReg = getAllocatedReg resReg val realOp1Reg = getAllocatedReg op1Reg in ArithToGenReg { opc=SUB, output=asGenReg realDestReg, source=codeExtArgumentAsGenReg operand2, opSize=opSize } :: moveIfNecessary({src=realOp1Reg, dst=realDestReg, kind=opSizeToIMove opSize}, code) end | codeExtended _ ({instr=ArithmeticFunction{oper, resultReg=PReg resReg, operand1=PReg op1Reg, operand2, opSize, ...}, ...}, code) = ( case decache operand2 of RegisterArgument(PReg op2Reg) => (* Arithmetic operation with both arguments as registers. These operations are all symmetric so we can try to put either argument into the result reg and then do the operation on the other arg. *) let val realDestReg = getAllocatedGenReg resReg val realOp1Reg = getAllocatedGenReg op1Reg and realOp2Reg = getAllocatedGenReg op2Reg val (operandReg, moveInstr) = if realOp1Reg = realDestReg then (realOp2Reg, code) else if realOp2Reg = realDestReg then (realOp1Reg, code) else (realOp2Reg, Move{source=RegisterArg realOp1Reg, destination=RegisterArg realDestReg, moveSize=opSizeToMove opSize} :: code) in ArithToGenReg { opc=oper, output=realDestReg, source=RegisterArg operandReg, opSize=opSize } :: moveInstr end | operand2 => (* Arithmetic operation with the first argument in a register and the second a constant or memory location. *) let val realDestReg = getAllocatedReg resReg val realOp1Reg = getAllocatedReg op1Reg val op2Arg = codeExtArgumentAsGenReg operand2 (* If we couldn't put it in the result register we have to copy it there. *) in ArithToGenReg { opc=oper, output=asGenReg realDestReg, source=op2Arg, opSize=opSize } :: moveIfNecessary({src=realOp1Reg, dst=realDestReg, kind=opSizeToIMove opSize}, code) end ) | codeExtended _ ({instr=TestTagBit{arg, ...}, ...}, code) = TestByteBits{arg=codeExtArgumentAsGenReg arg, bits=0w1} :: code | codeExtended _ ({instr=PushValue {arg, ...}, ...}, code) = PushToStack(codeExtArgumentAsGenReg arg) :: code | codeExtended _ ({instr=CopyToCache{source=PReg sreg, dest as PReg dreg, kind}, ...}, code) = if not (isUsed dest) then code else let val realDestReg = getAllocatedReg dreg (* Get the source register using the current destination as a preference. *) val realSrcReg = getAllocatedReg sreg in (* If the source is the same as the destination we don't need to do anything. *) moveIfNecessary({src=realSrcReg, dst=realDestReg, kind=kind}, code) end | codeExtended _ ({instr=ResetStackPtr {numWords, preserveCC}, ...}, code) = ( numWords >= 0 orelse raise InternalError "codeGenICode: ResetStackPtr - negative offset"; ResetStack{numWords=numWords, preserveCC=preserveCC} :: code ) | codeExtended _ ({instr=StoreToStack{ source, stackOffset, ... }, ...}, code) = llStoreArgument{ source=codeExtArgument source, base=esp, offset=stackOffset*Word.toInt nativeWordSize, index=NoIndex, kind=moveNativeWord} :: code | codeExtended _ ({instr=TagValue{source=PReg srcReg, dest as PReg dReg, opSize, ...}, ...}, code) = if not (isUsed dest) then code else let val regResult = asGenReg(getAllocatedReg dReg) val realSReg = asGenReg(getAllocatedReg srcReg) in (* N.B. Using LEA with a base register and an index multiplier of 1 is shorter than using no base register and a multiplier of two. *) (* TODO: If the value we're tagging is a byte or a 16-bit value we can use OpSize32 and possibly save the Rex byte. *) LoadAddress{ output=regResult, offset=1, base=SOME realSReg, index=Index1 realSReg, opSize=opSize } :: code end | codeExtended _ ({instr=UntagValue{dest as PReg dReg, cache=SOME(PReg cacheReg), opSize, ...}, ...}, code) = if not (isUsed dest) then code else moveIfNecessary({src=getAllocatedReg cacheReg, dst=getAllocatedReg dReg, kind=opSizeToIMove opSize}, code) | codeExtended _ ({instr=UntagValue{source=PReg sReg, dest as PReg dReg, isSigned, opSize, ...}, ...}, code) = if not (isUsed dest) then code else let val regResult = getAllocatedReg dReg val realSReg = getAllocatedReg sReg in (* For most cases we're going to be using a 32-bit word if this is 32-in-64. The exception is when converting a word to a signed large-word. *) ShiftConstant{ shiftType=if isSigned then SAR else SHR, output=asGenReg regResult, shift=0w1, opSize=opSize } :: moveIfNecessary({src=realSReg, dst=regResult, kind=opSizeToIMove opSize}, code) end | codeExtended _ ({instr=LoadEffectiveAddress{base, offset, index=ObjectIndex, dest=PReg dReg, opSize}, ...}, code) = let val destReg = asGenReg(getAllocatedReg dReg) val bReg = case base of SOME(PReg br) => asGenReg(getAllocatedReg br) | NONE => raise InternalError "LoadEffectiveAddress - ObjectIndex but no base" in LoadAddress{ output=destReg, offset=offset, base=SOME ebx, index=Index4 bReg, opSize=opSize } :: code end | codeExtended _ ({instr=LoadEffectiveAddress{base, offset, index, dest=PReg dReg, opSize}, ...}, code) = let val destReg = asGenReg(getAllocatedReg dReg) val bReg = case base of SOME(PReg br) => SOME(asGenReg(getAllocatedReg br)) | NONE => NONE val indexR = codeExtIndex index in LoadAddress{ output=destReg, offset=offset, base=bReg, index=indexR, opSize=opSize } :: code end | codeExtended _ ({instr=ShiftOperation{shift, resultReg=PReg resReg, operand=PReg operReg, shiftAmount=IntegerConstant i, opSize, ...}, ...}, code) = let val realDestReg = getAllocatedReg resReg val realOpReg = getAllocatedReg operReg in ShiftConstant{ shiftType=shift, output=asGenReg realDestReg, shift=Word8.fromLargeInt i, opSize=opSize } :: moveIfNecessary({src=realOpReg, dst=realDestReg, kind=opSizeToIMove opSize}, code) end | codeExtended _ ({instr=ShiftOperation{shift, resultReg=PReg resReg, operand=PReg operReg, shiftAmount=RegisterArgument(PReg shiftReg), opSize, ...}, ...}, code) = let val realDestReg = getAllocatedReg resReg val realShiftReg = getAllocatedReg shiftReg val realOpReg = getAllocatedReg operReg (* We want the shift in ecx. We may not have got it there but the register should be free. The shift is masked to 5 or 6 bits so we have to check for larger shift values at a higher level.*) in ShiftVariable{ shiftType=shift, output=asGenReg realDestReg, opSize=opSize } :: moveIfNecessary({src=realOpReg, dst=realDestReg, kind=opSizeToIMove opSize}, moveIfNecessary({src=realShiftReg, dst=GenReg ecx, kind=Move32Bit (* < 64*)}, code)) end | codeExtended _ ({instr=ShiftOperation _, ...}, _) = raise InternalError "codeExtended - ShiftOperation" | codeExtended _ ({instr= Multiplication{resultReg=PReg resReg, operand1=PReg op1Reg, operand2, opSize, ...}, ...}, code) = ( case decache operand2 of RegisterArgument(PReg op2Reg) => let (* Treat exactly the same as ArithmeticFunction. *) val realDestReg = getAllocatedGenReg resReg val realOp1Reg = getAllocatedGenReg op1Reg and realOp2Reg = getAllocatedGenReg op2Reg val (operandReg, moveInstr) = if realOp1Reg = realDestReg then (realOp2Reg, code) else if realOp2Reg = realDestReg then (realOp1Reg, code) else (realOp2Reg, Move{source=RegisterArg realOp1Reg, destination=RegisterArg realDestReg, moveSize=opSizeToMove opSize} :: code) in MultiplyR { source=RegisterArg operandReg, output=realDestReg, opSize=opSize } :: moveInstr end | operand2 => (* Multiply operation with the first argument in a register and the second a constant or memory location. *) let val realDestReg = getAllocatedReg resReg val realOp1Reg = getAllocatedReg op1Reg val op2Arg = codeExtArgumentAsGenReg operand2 in MultiplyR { output=asGenReg realDestReg, source=op2Arg, opSize=opSize } :: moveIfNecessary({src=realOp1Reg, dst=realDestReg, kind=opSizeToIMove opSize}, code) end ) | codeExtended _ ({instr=Division{isSigned, dividend=PReg regDivid, divisor, quotient=PReg regQuot, remainder=PReg regRem, opSize}, ...}, code) = let (* TODO: This currently only supports the dividend in a register. LargeWord division will generally load the argument from a box so we could support a memory argument for that case. Word and integer values will always have to be detagged. *) (* Division is specific as to the registers. The dividend must be eax, quotient is eax and the remainder is edx. *) val realDiviReg = getAllocatedReg regDivid val realQuotReg = getAllocatedReg regQuot val realRemReg = getAllocatedReg regRem val divisorArg = codeExtArgument divisor val divisorReg = argAsGenReg divisorArg val _ = divisorReg <> eax andalso divisorReg <> edx orelse raise InternalError "codeGenICode: Division" (* rdx needs to be set to the high order part of the dividend. For signed division that means sign-extending rdx, for unsigned division we clear it. We only need a 32-bit clear since the top 32-bits are cleared anyway. *) val setRDX = if isSigned then SignExtendForDivide opSize else ArithToGenReg{ opc=XOR, output=edx, source=RegisterArg edx, opSize=OpSize32 } in (* We may need to move one or more of the registers although normally that won't be necessary. Almost certainly only either the remainder or the quotient will actually be used. *) moveMultipleRegisters([{src=GenReg eax, dst=realQuotReg}, {src=GenReg edx, dst=realRemReg}], DivideAccR {arg=divisorReg, isSigned=isSigned, opSize=opSize} :: setRDX :: moveIfNecessary({src=realDiviReg, dst=GenReg eax, kind=opSizeToIMove opSize}, code)) end | codeExtended _ ({instr=AtomicExchangeAndAdd{base=PReg bReg, source=PReg sReg}, ...}, code) = let val baseReg = asGenReg (getAllocatedReg bReg) and outReg = asGenReg (getAllocatedReg sReg) val address = if targetArch = ObjectId32Bit then {base=ebx, index=Index4 baseReg, offset=0} else {base=baseReg, index=NoIndex, offset=0} in AtomicXAdd{address=address, output=outReg, opSize=polyWordOpSize} :: code end | codeExtended _ ({instr=BoxValue{boxKind, source=PReg sReg, dest as PReg dReg, saveRegs}, ...}, code) = if not (isUsed dest) then code else let val preserve = getSaveRegs saveRegs val (srcReg, boxSize, moveKind) = case boxKind of BoxLargeWord => (getAllocatedReg sReg, Word.toInt(nativeWordSize div wordSize), moveNativeWord) | BoxX87Double => (getAllocatedReg sReg, Word.toInt(0w8 div wordSize), MoveDouble) | BoxX87Float => (getAllocatedReg sReg, Word.toInt(0w4 div wordSize), MoveFloat) | BoxSSE2Double => (getAllocatedReg sReg, Word.toInt(0w8 div wordSize), MoveDouble) | BoxSSE2Float => (getAllocatedReg sReg, Word.toInt(0w4 div wordSize), MoveFloat) val dstReg = getAllocatedReg dReg val (bReg, index) = if targetArch = ObjectId32Bit then (ebx, Index4(asGenReg dstReg)) else (asGenReg dstReg, NoIndex) in StoreInitialised :: llStoreArgument{ source=RegisterArg srcReg, offset=0, base=bReg, index=index, kind=moveKind} :: llAllocateMemoryOperation({ size=boxSize, flags=0wx1, dest=dstReg, saveRegs=preserve}, code) end | codeExtended _ ({instr=CompareByteVectors{vec1Addr=PReg v1Reg, vec2Addr=PReg v2Reg, length=PReg lReg, ...}, ...}, code) = (* There's a complication here. CompareByteVectors generates REPE CMPSB to compare the vectors but the condition code is only set if CMPSB is executed at least once. If the value in RCX/ECX is zero it will never be executed and the condition code will be unchanged. We want the result to be "equal" in that case so we need to ensure that is the case. It's quite possible that the condition code has just been set by shifting RCX/ECX to remove the tag in which case it will have set "equal" if the value was zero. We use CMP R/ECX,R/ECX which is two bytes in 32-bit. If we knew the length was non-zero (e.g. a constant) we could avoid this. *) RepeatOperation CMPS8 :: ArithToGenReg {opc=CMP, output=ecx, source=RegisterArg ecx, opSize=OpSize32} :: moveIfNecessary({src=getAllocatedReg v1Reg, dst=GenReg esi, kind=moveNativeWord}, moveIfNecessary({src=getAllocatedReg v2Reg, dst=GenReg edi, kind=moveNativeWord}, moveIfNecessary({src=getAllocatedReg lReg, dst=GenReg ecx, kind=moveNativeWord}, code))) | codeExtended _ ({instr=BlockMove{srcAddr=PReg sReg, destAddr=PReg dReg, length=PReg lReg, isByteMove}, ...}, code) = (* We may need to move these into the appropriate registers. They have been reserved but it's still possible the values could be in something else. *) RepeatOperation(if isByteMove then MOVS8 else if polyWordOpSize = OpSize64 then MOVS64 else MOVS32) :: moveIfNecessary({src=getAllocatedReg sReg, dst=GenReg esi, kind=moveNativeWord}, moveIfNecessary({src=getAllocatedReg dReg, dst=GenReg edi, kind=moveNativeWord}, moveIfNecessary({src=getAllocatedReg lReg, dst=GenReg ecx, kind=moveNativeWord}, code))) | codeExtended _ ({instr=X87Compare{arg1=PReg argReg, arg2, isDouble, ...}, ...}, code) = let val fpReg = getAllocatedFPReg argReg val _ = fpReg = fp0 orelse raise InternalError "codeGenICode: CompareFloatingPt not fp0" (* This currently pops the value. *) val precision = if isDouble then DoublePrecision else SinglePrecision in case codeExtArgumentAsFPReg arg2 of RegisterArg fpReg2 => FPArithR{opc=FCOMP, source=fpReg2} :: code | MemoryArg{offset, base=baseReg, index=NoIndex} => FPArithMemory{opc=FCOMP, base=baseReg, offset=offset, precision=precision} :: code | AddressConstArg const => FPArithConst{opc=FCOMP, source = const, precision=precision} :: code | _ => raise InternalError "codeGenICode: CompareFloatingPt: TODO" end | codeExtended _ ({instr=SSE2Compare{arg1=PReg argReg, arg2, isDouble, ...}, ...}, code) = let val xmmReg = getAllocatedXMMReg argReg val arg2Code = codeExtArgumentAsXMMReg arg2 in XMMArith { opc= if isDouble then SSE2CompDouble else SSE2CompSingle, output=xmmReg, source=arg2Code} :: code end | codeExtended _ ({instr=X87FPGetCondition{dest=PReg dReg, ...}, ...}, code) = moveIfNecessary({src=GenReg eax, dst=getAllocatedReg dReg, kind=Move32Bit}, FPStatusToEAX :: code) | codeExtended _ ({instr=X87FPArith{opc, resultReg=PReg resReg, arg1=PReg op1Reg, arg2, isDouble}, ...}, code) = let val realDestReg = getAllocatedFPReg resReg val realOp1Reg = getAllocatedFPReg op1Reg val _ = realDestReg = fp0 orelse raise InternalError "codeGenICode: FloatingPointArith not fp0" val _ = realOp1Reg = fp0 orelse raise InternalError "codeGenICode: FloatingPointArith not fp0" val op2Arg = codeExtArgumentAsFPReg arg2 val precision = if isDouble then DoublePrecision else SinglePrecision in case op2Arg of MemoryArg{offset, base=baseReg, index=NoIndex} => FPArithMemory{opc=opc, base=baseReg, offset=offset, precision=precision} :: code | AddressConstArg const => FPArithConst{opc=opc, source = const, precision=precision} :: code | _ => raise InternalError "codeGenICode: X87FPArith: TODO" end | codeExtended _ ({instr=X87FPUnaryOps{fpOp, dest=PReg resReg, source=PReg op1Reg}, ...}, code) = let val realDestReg = getAllocatedFPReg resReg val realOp1Reg = getAllocatedFPReg op1Reg val _ = realDestReg = fp0 orelse raise InternalError "codeGenICode: X87FPUnaryOps not fp0" val _ = realOp1Reg = fp0 orelse raise InternalError "codeGenICode: X87FPUnaryOps not fp0" in FPUnary fpOp :: code end | codeExtended _ ({instr=X87Float{dest=PReg resReg, source}, ...}, code) = let val intSource = codeExtArgumentAsGenReg source val fpReg = getAllocatedFPReg resReg val _ = fpReg = fp0 orelse raise InternalError "codeGenICode: FloatFixedInt not fp0" in (* This is complicated. The integer value has to be in memory not in a register so we have to push it to the stack and then make sure it is popped afterwards. Because it is untagged it is unsafe to leave it. *) ResetStack{numWords=1, preserveCC=false} :: FPLoadInt{ base=esp, offset=0, opSize=polyWordOpSize } :: PushToStack intSource :: code end | codeExtended _ ({instr=SSE2Float{dest=PReg resReg, source}, ...}, code) = let val xmmResReg = getAllocatedXMMReg resReg val srcReg = case codeExtArgumentAsGenReg source of RegisterArg srcReg => srcReg | _ => raise InternalError "FloatFixedInt: not reg" in XMMConvertFromInt{ output=xmmResReg, source=srcReg, opSize=polyWordOpSize} :: code end | codeExtended _ ({instr=SSE2FPUnary{opc, resultReg=PReg resReg, source}, ...}, code) = let val realDestReg = getAllocatedXMMReg resReg val opArg = codeExtArgumentAsXMMReg source val sse2Op = case opc of SSE2UDoubleToFloat => SSE2DoubleToFloat | SSE2UFloatToDouble => SSE2FloatToDouble in XMMArith{ opc=sse2Op, output=realDestReg, source=opArg} :: code end | codeExtended _ ({instr=SSE2FPBinary{opc, resultReg=PReg resReg, arg1=PReg op1Reg, arg2}, ...}, code) = let val realDestReg = getAllocatedXMMReg resReg val realOp1Reg = getAllocatedXMMReg op1Reg val op2Arg = codeExtArgumentAsXMMReg arg2 (* xorpd and andpd require 128-bit arguments with 128-bit alignment. *) val _ = case (opc, op2Arg) of (SSE2BXor, RegisterArg _) => () | (SSE2BXor, _) => raise InternalError "codeGenICode - SSE2Xor not in register" | (SSE2BAnd, RegisterArg _) => () | (SSE2BAnd, _) => raise InternalError "codeGenICode - SSE2And not in register" | _ => () val doMove = if realDestReg = realOp1Reg then code else XMMArith { opc=SSE2MoveDouble, source=RegisterArg realOp1Reg, output=realDestReg } :: code val sse2Op = case opc of SSE2BAddDouble => SSE2AddDouble | SSE2BSubDouble => SSE2SubDouble | SSE2BMulDouble => SSE2MulDouble | SSE2BDivDouble => SSE2DivDouble | SSE2BAddSingle => SSE2AddSingle | SSE2BSubSingle => SSE2SubSingle | SSE2BMulSingle => SSE2MulSingle | SSE2BDivSingle => SSE2DivSingle | SSE2BXor => SSE2Xor | SSE2BAnd => SSE2And in XMMArith{ opc=sse2Op, output=realDestReg, source=op2Arg} :: doMove end | codeExtended _ ({instr=TagFloat{source=PReg srcReg, dest as PReg dReg, ...}, ...}, code) = if not (isUsed dest) then code else let val _ = targetArch = Native64Bit orelse raise InternalError "TagFloat: not 64-bit" (* Copy the value from an XMM reg into a general reg and tag it. *) val regResult = asGenReg(getAllocatedReg dReg) val realSReg = getAllocatedXMMReg srcReg in ArithToGenReg { opc=ADD, output=regResult, source=NonAddressConstArg 1, opSize=polyWordOpSize } :: ShiftConstant{ shiftType=SHL, output=regResult, shift=0w32, opSize=OpSize64} :: MoveXMMRegToGenReg { source = realSReg, output = regResult } :: code end | codeExtended _ ({instr=UntagFloat{dest as PReg dReg, cache=SOME(PReg cacheReg), ...}, ...}, code) = if not (isUsed dest) then code else moveIfNecessary({src=getAllocatedReg cacheReg, dst=getAllocatedReg dReg, kind=MoveFloat}, code) | codeExtended _ ({instr=UntagFloat{source, dest as PReg dReg, ...}, ...}, code) = if not (isUsed dest) then code else let val regResult = getAllocatedXMMReg dReg in case codeExtArgumentAsGenReg source of RegisterArg realSReg => XMMShiftRight{ output=regResult, shift=0w4 (* Bytes - not bits *) } :: MoveGenRegToXMMReg {source=realSReg, output=regResult} :: code | MemoryArg{base, offset, index} => (* If the value is in memory we can just load the high order word. *) XMMArith { opc=SSE2MoveFloat, source=MemoryArg{base=base, offset=offset+4, index=index}, output=regResult } :: code | NonAddressConstArg ic => (* Shift down and then load from the non-constant area. *) XMMArith { opc=SSE2MoveFloat, source=NonAddressConstArg(IntInf.~>>(ic, 0w32)), output=regResult } :: code | _ => raise InternalError "UntagFloat - not register or memory" end | codeExtended _ ({instr=GetSSE2ControlReg{dest=PReg dReg}, ...}, code) = let (* This has to work through memory. Reserve one word on the stack, get the MXCSR register into it and pop it to the register. *) val regResult = getAllocatedGenReg dReg in PopR regResult :: XMMStoreCSR{base=esp, offset=0, index=NoIndex } :: PushToStack(NonAddressConstArg 0) :: code end | codeExtended _ ({instr=SetSSE2ControlReg{source=PReg sReg}, ...}, code) = let (* This has to work through memory. Push the register to the stack, store the value into the control register and remove it from the stack. *) val sourceReg = getAllocatedGenReg sReg in ResetStack{ numWords=1, preserveCC=false } :: XMMLoadCSR{base=esp, offset=0, index=NoIndex } :: PushToStack(RegisterArg sourceReg) :: code end | codeExtended _ ({instr=GetX87ControlReg{dest=PReg dReg}, ...}, code) = let (* This has to work through memory. Reserve one word on the stack, get the X87 control register into it and pop it to the register. *) val regResult = getAllocatedGenReg dReg in PopR regResult :: FPStoreCtrlWord{base=esp, offset=0, index=NoIndex } :: PushToStack(NonAddressConstArg 0) :: code end | codeExtended _ ({instr=SetX87ControlReg{source=PReg sReg}, ...}, code) = let (* This has to work through memory. Push the register to the stack, store the value into the control register and remove it from the stack. *) val sourceReg = getAllocatedGenReg sReg in ResetStack{ numWords=1, preserveCC=false } :: FPLoadCtrlWord{base=esp, offset=0, index=NoIndex } :: PushToStack(RegisterArg sourceReg) :: code end | codeExtended _ ({instr=X87RealToInt{source=PReg sReg, dest=PReg dReg}, ...}, code) = let (* This has to work through memory. Reserve one word on the stack, convert the value into it and pop it to the register. *) val regResult = getAllocatedGenReg dReg val fpReg = getAllocatedFPReg sReg val _ = fpReg = fp0 orelse raise InternalError "codeGenICode: CompareFloatingPt not fp0" (* This currently pops the value. *) in PopR regResult :: FPStoreInt{base=esp, offset=0, index=NoIndex } :: PushToStack(NonAddressConstArg 0) :: code end | codeExtended _ ({instr=SSE2RealToInt{source, dest=PReg dReg, isDouble, isTruncate}, ...}, code) = let (* The source is either an XMM register or memory. *) val regResult = getAllocatedGenReg dReg val opArg = codeExtArgumentAsXMMReg source in XMMStoreInt { source=opArg, precision=if isDouble then DoublePrecision else SinglePrecision, output = regResult, isTruncate=isTruncate } :: code end | codeExtended _ ({instr=SignExtend32To64{source, dest=PReg dReg}, ...}, code) = let val regResult = getAllocatedGenReg dReg val opArg = codeExtArgumentAsGenReg source in Move{moveSize=Move32X64, source=opArg, destination=RegisterArg regResult } :: code end | codeExtended _ ({instr=TouchArgument _, ...}, code) = code (* Don't need to do anything. *) val newCode = codeCreate (functionName, profileObject, debugSwitches) local (* processed - set to true when a block has been processed. *) val processed = Array.array(numBlocks, false) fun haveProcessed n = Array.sub(processed, n) (* Find the blocks that reference this one. This isn't essential but allows us to try to generate blocks in the order of the control flow. This in turn may allow us to use short branches rather than long ones. *) val labelRefs = Array.array(numBlocks, []) datatype flowCode = FlowCodeSimple of int | FlowCodeCMove of {code: operation list, trueJump: int, falseJump: int} (* Process this recursively to set the references. If we have unreachable blocks, perhaps because they've been merged, we don't want to include them in the reference counting. This shouldn't happen now that IdentifyReferences removes unreferenced blocks. *) fun setReferences fromLabel toLabel = case Array.sub(labelRefs, toLabel) of [] => (* Not yet visited at all. *) let val ExtendedBasicBlock{ flow, ...} = Vector.sub(blocks, toLabel) val refs = case flow of ExitCode => [] | Unconditional lab => [lab] | Conditional{trueJump, falseJump, ... } => [trueJump, falseJump] | IndexedBr labs => labs | SetHandler { handler, continue } => [handler, continue] | UnconditionalHandle _ => [] | ConditionalHandle { continue, ...} => [continue] val () = if fromLabel >= 0 then Array.update(labelRefs, toLabel, [fromLabel]) else () in List.app (setReferences toLabel) refs end | refs => (* We've visiting this at least once. Just add us to the list. *) Array.update(labelRefs, toLabel, fromLabel :: refs) val _ = setReferences 0 0 (* Process the blocks. We keep the "stack" explicit rather than using recursion because this allows us to select both arms of a conditional branch sooner. *) fun genCode(toDo, lastFlow, code) = case List.filter (not o haveProcessed) toDo of [] => let (* There's nothing left to do. We may need to add a final branch to the end. *) val finalBranch = case lastFlow of ExitCode => [] | IndexedBr _ => [] | Unconditional dest => [UncondBranch(getBlockLabel dest)] | Conditional { condition, trueJump, falseJump, ...} => [ UncondBranch(getBlockLabel falseJump), ConditionalBranch{test=condition, label=getBlockLabel trueJump} ] | SetHandler { continue, ...} => [UncondBranch(getBlockLabel continue)] | UnconditionalHandle _ => [] | ConditionalHandle { continue, ...} => [UncondBranch(getBlockLabel continue)] in finalBranch @ code (* Done. *) end | stillToDo as head :: _ => let local (* Check the references. If all the sources that lead up to this have already been we won't have any backward jumps. *) fun available dest = List.all haveProcessed (Array.sub(labelRefs, dest)) val continuation = case lastFlow of ExitCode => NONE | IndexedBr _ => NONE (* We could put the last branch in here. *) | Unconditional dest => if not (haveProcessed dest) andalso available dest then SOME(FlowCodeSimple dest) else NONE | Conditional {trueJump, falseJump, condition, ...} => let (* Can we replace this with a SETCC or CMOV? If both arms simply set a register to a value and either return or jump to the same location we can use a SETCC or a CMOV. *) val ExtendedBasicBlock { flow=tFlow, block=tBlock, ...} = Vector.sub(blocks, trueJump) and ExtendedBasicBlock { flow=fFlow, block=fBlock, ...} = Vector.sub(blocks, falseJump) fun cmoveOrSetcc{condition, output, tSource=IntegerConstant trueValue, fSource=IntegerConstant falseValue, kind, code} = let (* Could use SETCC. Only if we can use LEA for multiplication. The result must be tagged so we will always have a multiplier. *) val (multiplier, fValue, testCondition) = if trueValue >= falseValue then (trueValue-falseValue, falseValue, condition) else (falseValue-trueValue, trueValue, invertTest condition) val destReg = asGenReg output in if not (targetArch = Native32Bit andalso (destReg=esi orelse destReg=edi)) (* We can't use Setcc with esi or edi on native 32-bit. *) andalso (multiplier = 2 orelse multiplier = 4 orelse multiplier = 8) (* We're using LEA so can only be multiplying by 2, 4 or 8. *) andalso is32bit fValue (* and we're going to put this in the offset *) then let val effectiveOpSize = (* We can generally use 32-bit LEA except if the result is negative. *) if kind = Move32Bit orelse fValue >= 0 andalso fValue+multiplier <= 0x7fffffff then OpSize32 else OpSize64 val (index, base) = case multiplier of 2 => (Index1 destReg, SOME destReg) | 4 => (Index4 destReg, NONE) | 8 => (Index8 destReg, NONE) | _ => (NoIndex, NONE) (* Try to put the instruction to zero the register before any compare. We can do it provided the register we're going to zero isn't used in the comparison. *) fun checkArg(RegisterArg r) = r <> destReg | checkArg(MemoryArg mem) = checkMem mem | checkArg _ = true and checkMem{base, index=NoIndex, ...} = base <> destReg | checkMem{base, index=Index1 index, ...} = base <> destReg andalso index <> destReg | checkMem{base, index=Index2 index, ...} = base <> destReg andalso index <> destReg | checkMem{base, index=Index4 index, ...} = base <> destReg andalso index <> destReg | checkMem{base, index=Index8 index, ...} = base <> destReg andalso index <> destReg val zeroReg = ArithToGenReg { opc=XOR, output=destReg, source=RegisterArg destReg, opSize=OpSize32 } fun addXOR [] = NONE | addXOR ((instr as ResetStack _) :: tl) = (* If we can add the XOR before the ResetStack do so. *) Option.map(fn code => instr :: code) (addXOR tl) | addXOR ((instr as ArithToGenReg{output, source, ...}) :: tl) = if output <> destReg andalso checkArg source then SOME(instr :: zeroReg :: tl) else NONE | addXOR ((instr as ArithMemConst{address, ...}) :: tl) = if checkMem address then SOME(instr :: zeroReg :: tl) else NONE | addXOR ((instr as ArithByteMemConst{address, ...}) :: tl) = if checkMem address then SOME(instr :: zeroReg :: tl) else NONE | addXOR ((instr as XMMArith{source=MemoryArg mem, ...}) :: tl) = if checkMem mem then SOME(instr :: zeroReg :: tl) else NONE | addXOR ((instr as XMMArith _) :: tl) = SOME(instr :: zeroReg :: tl) | addXOR ((instr as TestByteBits{arg, ...}) :: tl) = if checkArg arg then SOME(instr :: zeroReg :: tl) else NONE | addXOR ((instr as RepeatOperation CMPS8) :: tl) = (* This uses edi, esi and ecx implicitly *) if destReg <> esi andalso destReg <> edi andalso destReg <> ecx then SOME(instr :: zeroReg :: tl) else NONE (* This seems to be just a conditional jump as a result of testing the condition code twice in Real.== *) | addXOR _ = NONE (* If we can't put the XOR before the instruction we need to either zero it using a move which won't affect the CC or we use MOVZB to extend the byte value to 32/64 bits. *) val loadAddr = LoadAddress{output=destReg, offset=Int.fromLarge fValue, base=base, index=index, opSize=effectiveOpSize} and setCond = SetCondition{output=destReg, test=testCondition} val code = case addXOR code of SOME withXOR => loadAddr :: setCond :: withXOR | NONE => loadAddr :: (* We've already check that we're not using esi/edi on native 32-bits. *) Move{destination=RegisterArg destReg, source=RegisterArg destReg, moveSize=Move8} :: setCond :: code in SOME code end else NONE end (* If either value is a memory location it isn't safe to load it. The base address may not be valid if the condition does not hold. *) | cmoveOrSetcc{tSource=MemoryLocation _, ...} = NONE | cmoveOrSetcc{fSource=MemoryLocation _, ...} = NONE | cmoveOrSetcc{condition, output, tSource, fSource, kind, code} = if targetArch = Native32Bit then NONE (* CMov doesn't work for constants. *) else let val output = asGenReg output val codeTrue = codeExtArgumentAsGenReg tSource and codeFalse = codeExtArgumentAsGenReg fSource val opSize = case kind of Move32Bit => OpSize32 | Move64Bit => OpSize64 | _ => raise InternalError "move size" (* One argument has to be loaded into a register first and the other is conditionally moved. *) val loadFalseCmoveTrue = if (case codeFalse of RegisterArg regFalse => regFalse = output | _ => false) then true (* The false value is already in the right register. *) else if (case codeTrue of RegisterArg regTrue => regTrue = output | _ => false) then false (* The true value is in the right register - have to reverse. *) else if (case codeTrue of NonAddressConstArg _ => true | _ => false) then false (* The true value is a short constant. If we use a CMOV we will have to put that in the non-constant area and use a PC-relative reference. Try to avoid it. *) else true fun cmov{codeLoad, codeMove, condition} = let val load = case codeLoad of RegisterArg regLoad => moveIfNecessary({src=GenReg regLoad, dst=GenReg output, kind=opSizeToIMove opSize}, code) | codeLoad => Move{source=codeLoad, destination=RegisterArg output, moveSize=opSizeToMove opSize} :: code in CondMove{test=condition, output=output, source=codeMove, opSize=opSize} :: load end in if loadFalseCmoveTrue then SOME(cmov{codeLoad=codeFalse, codeMove=codeTrue, condition=condition}) else SOME(cmov{codeLoad=codeTrue, codeMove=codeFalse, condition=invertTest condition}) end val isPossSetCCOrCmov = if not (haveProcessed trueJump) andalso available trueJump andalso not (haveProcessed falseJump) andalso available falseJump then case (tFlow, fFlow, tBlock, fBlock) of (ExitCode, ExitCode, [{instr=LoadArgument{dest=PReg tReg, source=tSource, kind=kindT}, ...}, {instr=ReturnResultFromFunction{resultReg=PReg resReg, realReg, numStackArgs, ...}, ...}], [{instr=LoadArgument{dest=PReg fReg, source=fSource, kind=kindF}, ...}, {instr=ReturnResultFromFunction _, ...}]) => (* The real register for the two sides should both be rax. *) let val realTReg = getAllocatedReg tReg and realFReg = getAllocatedReg fReg in if realTReg = realFReg andalso kindT = kindF andalso (kindT = Move32Bit orelse kindT = Move64Bit) then ( case cmoveOrSetcc{condition=condition, output=realTReg, tSource=tSource, fSource=fSource, kind=kindT, code=code} of SOME code => let val resultReg = getAllocatedReg resReg val code = ReturnFromFunction numStackArgs :: moveIfNecessary({src=resultReg, dst=realReg, kind=moveNativeWord}, code) in SOME{code=code, trueJump=trueJump, falseJump=falseJump} end | NONE => NONE ) else NONE end | (Unconditional tDest, Unconditional fDest, [{instr=LoadArgument{dest=PReg tReg, source=tSource, kind=kindT}, ...}], [{instr=LoadArgument{dest=PReg fReg, source=fSource, kind=kindF}, ...}]) => let val realTReg = getAllocatedReg tReg and realFReg = getAllocatedReg fReg in if tDest = fDest andalso realTReg = realFReg andalso kindT = kindF andalso (kindT = Move32Bit orelse kindT = Move64Bit) then ( case cmoveOrSetcc{condition=condition, output=realTReg, tSource=tSource, fSource=fSource, kind=kindT, code=code} of SOME code => SOME{code=code, trueJump=trueJump, falseJump=falseJump} | NONE => NONE ) else NONE end | _ => NONE else NONE in case isPossSetCCOrCmov of NONE => (* We can usually choose either destination and in nearly all cases it won't matter. The default branch is not to take forward jumps so if there is reason to believe that one branch is more likely we should follow that branch now and leave the other. If we have JO/JNO we assume that overflow is unusual. If one branch raises an exception we assume that that is unusual. *) let val (first, second) = case (condition, Vector.sub(blocks, falseJump)) of (JNO, _) => (trueJump, falseJump) | (_, ExtendedBasicBlock{ flow=ExitCode, block, ...}) => if List.exists(fn{instr=RaiseExceptionPacket _, ...} => true | _ => false) block then (trueJump, falseJump) else (falseJump, trueJump) | _ => (falseJump, trueJump) in if not (haveProcessed first) andalso available first then SOME(FlowCodeSimple first) else if not (haveProcessed second) andalso available second then SOME(FlowCodeSimple second) else NONE end | SOME args => SOME(FlowCodeCMove args) end | SetHandler { continue, ... } => (* We want the continuation if possible. We'll need a branch round the handler so that won't help. *) if not (haveProcessed continue) andalso available continue then SOME(FlowCodeSimple continue) else NONE | UnconditionalHandle _ => NONE | ConditionalHandle _ => NONE in (* First choice - continue the existing block. Second choice - the first item whose sources have all been processed. Third choice - something from the list. *) val picked = case continuation of SOME c => c | NONE => case List.find available stillToDo of SOME c => FlowCodeSimple c | NONE => FlowCodeSimple head end in case picked of FlowCodeSimple picked => let val () = Array.update(processed, picked, true) (* Code to terminate the previous block. *) val startCode = case lastFlow of ExitCode => [] | IndexedBr _ => [] | UnconditionalHandle _ => [] | Unconditional dest => if dest = picked then [] else [UncondBranch(getBlockLabel dest)] | ConditionalHandle { continue, ...} => if continue = picked then [] else [UncondBranch(getBlockLabel continue)] | SetHandler { continue, ... } => if continue = picked then [] else [UncondBranch(getBlockLabel continue)] | Conditional { condition, trueJump, falseJump, ...} => if picked = falseJump (* Usual case. *) then [ConditionalBranch{test=condition, label=getBlockLabel trueJump}] else if picked = trueJump then (* We have a jump to the true condition. Invert the jump. This is more than an optimisation. Because this immediately precedes the true block we're not going to generate a label. *) [ConditionalBranch{test=invertTest condition, label=getBlockLabel falseJump}] else [ UncondBranch(getBlockLabel falseJump), ConditionalBranch{test=condition, label=getBlockLabel trueJump} ] (* Code-generate the body with the code we've done so far at the end. Add a label at the start if necessary. *) local (* If the previous block dropped through to this and this was the only reference then we don't need a label. *) fun onlyJumpingHere (lab: int) = if lab <> picked then false else case Array.sub(labelRefs, picked) of [singleton] => singleton = lab | _ => false val noLabel = case lastFlow of ExitCode => picked = 0 (* Unless this was the first block. *) | Unconditional dest => onlyJumpingHere dest | Conditional { trueJump, falseJump, ...} => onlyJumpingHere trueJump orelse onlyJumpingHere falseJump | IndexedBr _ => false | SetHandler _ => false | UnconditionalHandle _ => false | ConditionalHandle { continue, ...} => onlyJumpingHere continue in val startLabel = if noLabel then [] else [JumpLabel(getBlockLabel picked)] end val ExtendedBasicBlock { flow, block, ...} = Vector.sub(blocks, picked) local fun genCodeBlock(instr, code) = codeExtended {flow=flow} (instr, code) in val bodyCode = List.foldl genCodeBlock (startLabel @ startCode @ code) block end val addSet = case flow of ExitCode => [] | IndexedBr cases => cases | Unconditional dest => [dest] | Conditional {trueJump, falseJump, ...} => [falseJump, trueJump] | SetHandler { handler, continue } => [handler, continue] | UnconditionalHandle _ => [] | ConditionalHandle { continue, ...} => [continue] in genCode(addSet @ stillToDo, flow, bodyCode) end | FlowCodeCMove{code, trueJump, falseJump} => let (* We've generated a conditional move and possibly a return. If the trueJump and falseJump are only ever referenced from this block they're done, otherwise we still need to do them. *) val _ = case Array.sub(labelRefs, trueJump) of [_] => Array.update(processed, trueJump, true) | _ => () val _ = case Array.sub(labelRefs, falseJump) of [_] => Array.update(processed, falseJump, true) | _ => () val ExtendedBasicBlock { flow, ...} = Vector.sub(blocks, trueJump) val addSet = case flow of ExitCode => [] | Unconditional dest => [dest] | _ => raise InternalError "FlowCodeCMove" in genCode(addSet @ stillToDo, flow, code) end end in val ops = genCode([0], ExitCode, []) end in X86OPTIMISE.generateCode{code=newCode, ops=List.rev ops, labelCount= !outputLabelCount, resultClosure=resultClosure} end val nGenRegs = List.length generalRegisters structure Sharing = struct type intSet = intSet and extendedBasicBlock = extendedBasicBlock and regProperty = regProperty and reg = reg and closureRef = closureRef end end; diff --git a/mlsource/MLCompiler/CodeTree/X86Code/X86ICodeTransform.ML b/mlsource/MLCompiler/CodeTree/X86Code/X86ICodeTransform.ML index 2860634c..b208e25a 100644 --- a/mlsource/MLCompiler/CodeTree/X86Code/X86ICodeTransform.ML +++ b/mlsource/MLCompiler/CodeTree/X86Code/X86ICodeTransform.ML @@ -1,327 +1,327 @@ (* - Copyright David C. J. Matthews 2016-17 + Copyright David C. J. Matthews 2016-17, 2020 This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) functor X86ICodeTransform( structure ICODE: ICodeSig - structure DEBUG: DEBUGSIG + structure DEBUG: DEBUG structure CODEGEN: X86ICODEGENERATESIG structure ALLOCATE: X86ALLOCATEREGISTERSSIG structure IDENTIFY: X86IDENTIFYREFSSIG structure CONFLICTSETS: X86GETCONFLICTSETSIG structure PUSHREGISTERS: X86PUSHREGISTERSIG structure OPTIMISE: X86ICODEOPTSIG structure PRETTY: PRETTYSIG structure INTSET: INTSETSIG sharing ICODE.Sharing = CODEGEN.Sharing = ALLOCATE.Sharing = IDENTIFY.Sharing = CONFLICTSETS.Sharing = PUSHREGISTERS.Sharing = INTSET = OPTIMISE.Sharing ) : X86ICODETRANSFORMSIG = struct open ICODE open Address open IDENTIFY open CONFLICTSETS open PUSHREGISTERS open INTSET open CODEGEN open ALLOCATE open OPTIMISE exception InternalError = Misc.InternalError (* Find out the registers that need to be pushed to the stack, if any. We include those marked as "must push" because we need to save them across a function call or handler and also any we need to push because the set of active registers is more than the number of general registers we have. This second case involves choosing suitable registers and is a first attempt to check we have enough registers. We can also get a failure in codeExtended when we actually allocate the registers. *) fun spillRegisters(identified: extendedBasicBlock vector, regStates: regState vector) = let val maxPRegs = Vector.length regStates val pushArray = Array.array(maxPRegs, false) (* Mark anything already marked as "must push" unless it's already on the stack *) local fun checkPush(i, {pushState=true, ...}) = Array.update(pushArray, i, true) | checkPush _ = () in val () = Vector.appi checkPush regStates end (* Make a list of all the active sets ignoring those marked to be pushed. Do that first because we need to know how many sets each register is in. *) local fun addToActive(r, l) = ( case Vector.sub(regStates, r) of {prop=RegPropStack _, ...} => l | _ => if Array.sub(pushArray, r) then l else r :: l ) in fun nowActive regs = List.foldl addToActive [] regs end fun getBlockSets(ExtendedBasicBlock{block, passThrough, ...}, sets) = let fun getSets({active, ...}, l) = let val set = nowActive(setToList(union(active, passThrough))) in if List.length set > nGenRegs then set :: l else l end in List.foldl getSets sets block end val activeSets = Vector.foldl getBlockSets [] identified in if null activeSets then () else let (* See how many times each register appears in a set. *) val activeIn = Array.array(maxPRegs, 0) val () = List.app (fn regs => List.app(fn r => Array.update(activeIn, r, Array.sub(activeIn, r)+1)) regs) activeSets (* We want to choose the best registers to spill. *) fun spillSomeRegs activeSet = let (* We may have already marked some of these to push. *) val currentActive = nowActive activeSet val regCount = List.length currentActive fun addCosts r = let val {active, refs, prop, ...} = Vector.sub(regStates, r) in case prop of RegPropUntagged => (r, ~1, ~1) | RegPropStack _ => (r, ~1, ~1) | RegPropMultiple => (r, ~1, ~1) | _ => (r, Array.sub(activeIn, r), if refs = 0 then 0 else Int.quot(active, refs)) end val withCosts = List.map addCosts currentActive (* Order so that the earlier items are those that appear in more sets and if items appear in the same number of sets those that are active longer come earlier. *) fun compare (_, in1, a1) (_, in2, a2) = if in1 > in2 then true else if in1 < in2 then false else a1 > a2 val sorted = Misc.quickSort compare withCosts fun markAsPush([], _) = () | markAsPush((reg, _, _) :: regs, n) = if n <= 0 then () else let val {prop, ...} = Vector.sub(regStates, reg) val _ = case prop of RegPropStack _ => raise InternalError "markAsPush" | _ => () in Array.update(pushArray, reg, true); markAsPush(regs, n-1) end in markAsPush(sorted, regCount-nGenRegs) end in List.app spillSomeRegs activeSets end; (* Return the vector showing those that must be pushed. *) Array.vector pushArray end type triple = {instr: x86ICode, current: intSet, active: intSet} fun codeICodeFunctionToX86{blocks, functionName, pregProps, ccCount, debugSwitches, resultClosure, ...} = let (*val maxPRegs = Vector.length pregProps*) val icodeTabs = [8, 20, 60] val wantPrintCode = DEBUG.getParameter DEBUG.icodeTag debugSwitches fun printCode identifiedCode = (* Print the code before the transformation. *) let val printStream = PRETTY.getSimplePrinter(debugSwitches, icodeTabs) in printStream(functionName ^ "\n"); printICodeAbstract(identifiedCode, printStream); printStream "\n" end fun printConflicts(regStates: conflictState vector) = let val printStream = PRETTY.getSimplePrinter(debugSwitches, icodeTabs) fun printRegs([], _) = () | printRegs(_, 0) = printStream "..." | printRegs([i], _) = printStream(Int.toString i) | printRegs(i::l, n) = (printStream(Int.toString i ^ ","); printRegs(l, n-1)) fun printRegData(i, { conflicts, ... }) = ( printStream (Int.toString i ^ "\t"); printStream ("Conflicts="); printRegs(setToList conflicts, 20); printStream "\n" ) in Vector.appi printRegData regStates end fun printRegisters(regAlloc: reg vector) = let val printStream = PRETTY.getSimplePrinter(debugSwitches, icodeTabs) fun printRegAlloc(i, reg) = printStream (Int.toString i ^ "\t=> " ^ regRepr reg ^ "\n"); in Vector.appi printRegAlloc regAlloc end (* Limit the number of passes. *) val maxOptimisePasses = 30 val maxTotalPasses = maxOptimisePasses + 40 fun processCode(basicBlocks: basicBlock vector, pregProps: regProperty vector, maxStack, passes, optPasses) = let (* This should only require a few passes. *) val _ = passes < maxTotalPasses orelse raise InternalError "Too many passes" val () = if wantPrintCode then printCode basicBlocks else () (* First pass - identify register use patterns *) val (identified, regStates) = identifyRegisters(basicBlocks, pregProps) (* Try optimising. This may not do anything in which case we can continue with the original code otherwise we need to reprocess. *) val tryOpt = if optPasses < maxOptimisePasses then optimiseICode{code=identified, pregProps=pregProps, ccCount=ccCount, debugSwitches=debugSwitches} else Unchanged in case tryOpt of Changed (postOptimise, postOpProps) => processCode(postOptimise, postOpProps, maxStack, passes, optPasses+1) | Unchanged => let val regsToSpill = spillRegisters(identified, regStates) val needPhase2 = Vector.exists(fn t => t) regsToSpill val (needPhase2, regsToSpill) = if needPhase2 orelse passes <> 0 then (needPhase2, regsToSpill) else (true, Vector.tabulate(Vector.length pregProps, fn _ => false)) in if needPhase2 then let (* Push those registers we need to. This also adds and renumbers pregs and may add labels. *) val {code=postPushCode, pregProps=regPropsPhase2, maxStack=maxStackPhase2} = addRegisterPushes{code=identified, pushVec=regsToSpill, pregProps=pregProps, firstPass=passes=0} in (* And reprocess. *) processCode(postPushCode, regPropsPhase2, maxStackPhase2, passes+1, optPasses) end else let val maxPRegs = Vector.length regStates (* If we have been unable to allocate a register we need to spill something. Choose a single register from each conflict set. Since we've already checked that the active sets are small enough this is really only required to deal with special requirements e.g. esi/edi in block moves. *) fun spillFromConflictSets conflictSets = let val maxPRegs = Vector.length regStates val pushArray = Array.array(maxPRegs, false) fun selectARegisterToSpill active = let val regsToPick = setToList active in (* If we have already marked one of these to be pushed we don't need to do anything here. *) if List.exists (fn r => Array.sub(pushArray, r)) regsToPick then () else (* Choose something to push. *) let fun chooseReg([], bestReg, _) = bestReg | chooseReg(reg::regs, bestReg, bestCost) = let val {active, refs, prop, ...} = Vector.sub(regStates, reg) val cost = if refs = 0 then 0 else Int.quot(active, refs) in case prop of RegPropStack _ => chooseReg(regs, bestReg, bestCost) | RegPropCacheUntagged => reg (* Pick the first cache reg. *) | RegPropCacheTagged => reg (* Pick the first cache reg. *) | _ => if cost >= bestCost then chooseReg(regs, reg, active) else chooseReg(regs, bestReg, bestCost) end val choice = chooseReg(regsToPick, ~1, 0) val _ = choice >= 0 orelse raise InternalError "chooseReg" in Array.update(pushArray, choice, true) end end val () = List.app selectARegisterToSpill conflictSets in Array.vector pushArray end (* Now get the conflict sets. *) val conflictSets = getConflictStates(identified, maxPRegs) local fun mapFromExtended(ExtendedBasicBlock{block, flow, ...}) = BasicBlock{block=List.map #instr block, flow=flow} in val () = if wantPrintCode then (printCode(Vector.map mapFromExtended identified); printConflicts conflictSets) else () end in case allocateRegisters {blocks=identified, regStates=conflictSets, regProps=pregProps } of AllocateSuccess allocatedRegs => ( if wantPrintCode then printRegisters allocatedRegs else (); icodeToX86Code{blocks=identified, functionName=functionName, allocatedRegisters=allocatedRegs, stackRequired=maxStack, debugSwitches=debugSwitches, resultClosure=resultClosure} ) | AllocateFailure fails => let val regsToSpill = spillFromConflictSets fails val {code=postPushCode, pregProps=pregPropsPhase2, maxStack=maxStackPhase2} = addRegisterPushes{code=identified, pushVec=regsToSpill, pregProps=pregProps, firstPass=false} in processCode(postPushCode, pregPropsPhase2, maxStackPhase2, passes+1, optPasses) end end end end in processCode(blocks, pregProps, 0 (* Should include handlers and containers. *), 0, 0) end structure Sharing = struct type preg = preg and reg = reg and basicBlock = basicBlock and regProperty = regProperty and closureRef = closureRef end end; diff --git a/mlsource/MLCompiler/CodeTree/X86Code/X86OUTPUTCODE.ML b/mlsource/MLCompiler/CodeTree/X86Code/X86OUTPUTCODE.ML index e38c1020..faf1dec1 100644 --- a/mlsource/MLCompiler/CodeTree/X86Code/X86OUTPUTCODE.ML +++ b/mlsource/MLCompiler/CodeTree/X86Code/X86OUTPUTCODE.ML @@ -1,4014 +1,4014 @@ (* - Copyright David C. J. Matthews 1989, 2000, 2009-10, 2012-13, 2015-19 + Copyright David C. J. Matthews 1989, 2000, 2009-10, 2012-13, 2015-20 Based on original code: Copyright (c) 2000 Cambridge University Technical Services Limited This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) (* Title: Code Generator Routines. Author: Dave Matthews, Cambridge University Computer Laboratory Copyright Cambridge University 1989 *) (* This module contains the code vector and operations to insert code into it. Each procedure is compiled into a separate segment. Initially it is compiled into a fixed size segment, and then copied into a segment of the correct size at the end. This module contains all the definitions of the X86 opCodes and registers. It uses "codeseg" to create and operate on the segment itself. *) functor X86OUTPUTCODE ( -structure DEBUG: DEBUGSIG +structure DEBUG: DEBUG structure PRETTY: PRETTYSIG (* for compilerOutTag *) structure CODE_ARRAY: CODEARRAYSIG ) : X86CODESIG = struct open CODE_ARRAY open DEBUG open Address open Misc (* May be targeted at native 32-bit, native 64-bit or X86/64 with 32-bit words and addresses as object Ids. *) datatype targetArch = Native32Bit | Native64Bit | ObjectId32Bit val targetArch = case PolyML.architecture() of "I386" => Native32Bit | "X86_64" => Native64Bit | "X86_64_32" => ObjectId32Bit | _ => raise InternalError "Unknown target architecture" (* Some checks - *) val () = case (targetArch, wordSize, nativeWordSize) of (Native32Bit, 0w4, 0w4) => () | (Native64Bit, 0w8, 0w8) => () | (ObjectId32Bit, 0w4, 0w8) => () | _ => raise InternalError "Mismatch of architecture and word-length" val hostIsX64 = targetArch <> Native32Bit infix 5 << <<+ <<- >> >>+ >>- ~>> ~>>+ ~>>- (* Shift operators *) infix 3 andb orb xorb andbL orbL xorbL andb8 orb8 xorb8 val op << = Word.<< and op >> = Word.>> val (*op <<+ = LargeWord.<< and *) op >>+ = LargeWord.>> val op <<- = Word8.<< and op >>- = Word8.>> val op orb8 = Word8.orb val op andb8 = Word8.andb val op andb = Word.andb (* and op andbL = LargeWord.andb *) and op orb = Word.orb val wordToWord8 = Word8.fromLargeWord o Word.toLargeWord (*and word8ToWord = Word.fromLargeWord o Word8.toLargeWord*) val exp2_16 = 0x10000 val exp2_31 = 0x80000000: LargeInt.int (* Returns true if this a 32-bit machine or if the constant is within 32-bits. This is exported to the higher levels. N.B. The test for not isX64 avoids a significant overhead with arbitrary precision arithmetic on X86/32. *) fun is32bit v = not hostIsX64 orelse ~exp2_31 <= v andalso v < exp2_31 (* tag a short constant *) fun tag c = 2 * c + 1; fun is8BitL (n: LargeInt.int) = ~ 0x80 <= n andalso n < 0x80 local val shift = if wordSize = 0w4 then 0w2 else if wordSize = 0w8 then 0w3 else raise InternalError "Invalid word size for x86_32 or x86+64" in fun wordsToBytes n = n << shift and bytesToWords n = n >> shift end infix 6 addrPlus addrMinus; (* All indexes into the code vector have type "addrs". This is really a legacy. *) type addrs = Word.word val addrZero = 0w0 (* This is the external label type used when constructing operations. *) datatype label = Label of { labelNo: int } (* Constants which are too large to go inline in the code are put in a list and put at the end of the code. They are arranged so that the garbage collector can find them and change them as necessary. A reference to a constant is treated like a forward reference to a label. *) datatype code = Code of { procName: string, (* Name of the procedure. *) printAssemblyCode:bool, (* Whether to print the code when we finish. *) printStream: string->unit, (* The stream to use *) lowLevelOptimise: bool, (* Whether to do the low-level optimisation pass *) profileObject : machineWord (* The profile object for this code. *) } (* Exported functions *) fun lowLevelOptimise(Code{lowLevelOptimise, ...}) = lowLevelOptimise (* EBP/RBP points to a structure that interfaces to the RTS. These are offsets into that structure. *) val memRegLocalMPointer = 0 (* Not used in 64-bit *) and memRegHandlerRegister = Word.toInt nativeWordSize and memRegLocalMbottom = 2 * Word.toInt nativeWordSize and memRegStackLimit = 3 * Word.toInt nativeWordSize and memRegExceptionPacket = 4 * Word.toInt nativeWordSize and memRegCStackPtr = 6 * Word.toInt nativeWordSize and memRegThreadSelf = 7 * Word.toInt nativeWordSize and memRegStackPtr = 8 * Word.toInt nativeWordSize and memRegHeapOverflowCall = 10 * Word.toInt nativeWordSize and memRegStackOverflowCall = 11 * Word.toInt nativeWordSize and memRegStackOverflowCallEx = 12 * Word.toInt nativeWordSize and memRegSavedRbx = 14 * Word.toInt nativeWordSize (* Heap base in 32-in-64. *) (* create and initialise a code segment *) fun codeCreate (name : string, profObj, parameters) : code = let val printStream = PRETTY.getSimplePrinter(parameters, []) in Code { procName = name, printAssemblyCode = DEBUG.getParameter DEBUG.assemblyCodeTag parameters, printStream = printStream, lowLevelOptimise = DEBUG.getParameter DEBUG.lowlevelOptimiseTag parameters, profileObject = profObj } end (* Put 1 unsigned byte at a given offset in the segment. *) fun set8u (b, addr, seg) = byteVecSet (seg, addr, b) (* Put 4 bytes at a given offset in the segment. *) (* b0 is the least significant byte. *) fun set4Bytes (b3, b2, b1, b0, addr, seg) = let val a = addr; in (* Little-endian *) byteVecSet (seg, a, b0); byteVecSet (seg, a + 0w1, b1); byteVecSet (seg, a + 0w2, b2); byteVecSet (seg, a + 0w3, b3) end; (* Put 1 unsigned word at a given offset in the segment. *) fun set32u (ival: LargeWord.word, addr, seg) : unit = let val b3 = Word8.fromLargeWord (ival >>+ 0w24) val b2 = Word8.fromLargeWord (ival >>+ 0w16) val b1 = Word8.fromLargeWord (ival >>+ 0w8) val b0 = Word8.fromLargeWord ival in set4Bytes (b3, b2, b1, b0, addr, seg) end (* Put 1 signed word at a given offset in the segment. *) fun set32s (ival: LargeInt.int, addr, seg) = set32u(LargeWord.fromLargeInt ival, addr, seg) fun byteSigned ival = if ~0x80 <= ival andalso ival < 0x80 then Word8.fromInt ival else raise InternalError "byteSigned: invalid byte" (* Convert a large-word value to a little-endian byte sequence. *) fun largeWordToBytes(_, 0) = [] | largeWordToBytes(ival: LargeWord.word, n) = Word8.fromLargeWord ival :: largeWordToBytes(ival >>+ 0w8, n-1) fun word32Unsigned(ival: LargeWord.word) = largeWordToBytes(ival, 4) fun int32Signed(ival: LargeInt.int) = if is32bit ival then word32Unsigned(LargeWord.fromLargeInt ival) else raise InternalError "int32Signed: invalid word" (* Registers. *) datatype genReg = GeneralReg of Word8.word * bool and fpReg = FloatingPtReg of Word8.word and xmmReg = SSE2Reg of Word8.word datatype reg = GenReg of genReg | FPReg of fpReg | XMMReg of xmmReg (* These are the real registers we have. The AMD extension encodes the additional registers through the REX prefix. *) val rax = GeneralReg (0w0, false) val rcx = GeneralReg (0w1, false) val rdx = GeneralReg (0w2, false) val rbx = GeneralReg (0w3, false) val rsp = GeneralReg (0w4, false) val rbp = GeneralReg (0w5, false) val rsi = GeneralReg (0w6, false) val rdi = GeneralReg (0w7, false) val eax = rax and ecx = rcx and edx = rdx and ebx = rbx and esp = rsp and ebp = rbp and esi = rsi and edi = rdi val r8 = GeneralReg (0w0, true) val r9 = GeneralReg (0w1, true) val r10 = GeneralReg (0w2, true) val r11 = GeneralReg (0w3, true) val r12 = GeneralReg (0w4, true) val r13 = GeneralReg (0w5, true) val r14 = GeneralReg (0w6, true) val r15 = GeneralReg (0w7, true) (* Floating point "registers". Actually entries on the floating point stack. The X86 has a floating point stack with eight entries. *) val fp0 = FloatingPtReg 0w0 and fp1 = FloatingPtReg 0w1 and fp2 = FloatingPtReg 0w2 and fp3 = FloatingPtReg 0w3 and fp4 = FloatingPtReg 0w4 and fp5 = FloatingPtReg 0w5 and fp6 = FloatingPtReg 0w6 and fp7 = FloatingPtReg 0w7 (* SSE2 Registers. These are used for floating point in 64-bity mode. We only use XMM0-6 because the others are callee save and we don't currently save them. *) val xmm0 = SSE2Reg 0w0 and xmm1 = SSE2Reg 0w1 and xmm2 = SSE2Reg 0w2 and xmm3 = SSE2Reg 0w3 and xmm4 = SSE2Reg 0w4 and xmm5 = SSE2Reg 0w5 and xmm6 = SSE2Reg 0w6 and xmm7 = SSE2Reg 0w7 fun getReg (GeneralReg r) = r fun mkReg n = GeneralReg n (* reg.up *) (* The maximum size of the register vectors and masks. Although the X86/32 has a floating point stack with eight entries it's much simpler to treat it as having seven "real" registers. Items are pushed to the stack and then stored and popped into the current location. It may be possible to improve the code by some peephole optimisation. *) val regs = 30 (* Include the X86/64 registers even if this is 32-bit. *) (* The nth register (counting from 0). *) (* Profiling shows that applying the constructors here creates a lot of garbage. Create the entries once and then use vector indexing instead. *) local fun regN i = if i < 8 then GenReg(GeneralReg(Word8.fromInt i, false)) else if i < 16 then GenReg(GeneralReg(Word8.fromInt(i-8), true)) else if i < 23 then FPReg(FloatingPtReg(Word8.fromInt(i-16))) else XMMReg(SSE2Reg(Word8.fromInt(i-23))) val regVec = Vector.tabulate(regs, regN) in fun regN i = Vector.sub(regVec, i) handle Subscript => raise InternalError "Bad register number" end (* The number of the register. *) fun nReg(GenReg(GeneralReg(r, false))) = Word8.toInt r | nReg(GenReg(GeneralReg(r, true))) = Word8.toInt r + 8 | nReg(FPReg(FloatingPtReg r)) = Word8.toInt r + 16 | nReg(XMMReg(SSE2Reg r)) = Word8.toInt r + 23 datatype opsize = SZByte | SZWord | SZDWord | SZQWord (* Default size when printing regs. *) val sz32_64 = if hostIsX64 then SZQWord else SZDWord fun genRegRepr(GeneralReg (0w0, false), SZByte) = "al" | genRegRepr(GeneralReg (0w1, false), SZByte) = "cl" | genRegRepr(GeneralReg (0w2, false), SZByte) = "dl" | genRegRepr(GeneralReg (0w3, false), SZByte) = "bl" | genRegRepr(GeneralReg (0w4, false), SZByte) = "ah" | genRegRepr(GeneralReg (0w5, false), SZByte) = "ch" | genRegRepr(GeneralReg (0w6, false), SZByte) = "sil" (* Assume there's a Rex code that forces low-order reg *) | genRegRepr(GeneralReg (0w7, false), SZByte) = "dil" | genRegRepr(GeneralReg (reg, true), SZByte) = "r" ^ Int.toString(Word8.toInt reg +8) ^ "b" | genRegRepr(GeneralReg (0w0, false), SZDWord) = "eax" | genRegRepr(GeneralReg (0w1, false), SZDWord) = "ecx" | genRegRepr(GeneralReg (0w2, false), SZDWord) = "edx" | genRegRepr(GeneralReg (0w3, false), SZDWord) = "ebx" | genRegRepr(GeneralReg (0w4, false), SZDWord) = "esp" | genRegRepr(GeneralReg (0w5, false), SZDWord) = "ebp" | genRegRepr(GeneralReg (0w6, false), SZDWord) = "esi" | genRegRepr(GeneralReg (0w7, false), SZDWord) = "edi" | genRegRepr(GeneralReg (reg, true), SZDWord) = "r" ^ Int.toString(Word8.toInt reg +8) ^ "d" | genRegRepr(GeneralReg (0w0, false), SZQWord) = "rax" | genRegRepr(GeneralReg (0w1, false), SZQWord) = "rcx" | genRegRepr(GeneralReg (0w2, false), SZQWord) = "rdx" | genRegRepr(GeneralReg (0w3, false), SZQWord) = "rbx" | genRegRepr(GeneralReg (0w4, false), SZQWord) = "rsp" | genRegRepr(GeneralReg (0w5, false), SZQWord) = "rbp" | genRegRepr(GeneralReg (0w6, false), SZQWord) = "rsi" | genRegRepr(GeneralReg (0w7, false), SZQWord) = "rdi" | genRegRepr(GeneralReg (reg, true), SZQWord) = "r" ^ Int.toString(Word8.toInt reg +8) | genRegRepr(GeneralReg (0w0, false), SZWord) = "ax" | genRegRepr(GeneralReg (0w1, false), SZWord) = "cx" | genRegRepr(GeneralReg (0w2, false), SZWord) = "dx" | genRegRepr(GeneralReg (0w3, false), SZWord) = "bx" | genRegRepr(GeneralReg (0w4, false), SZWord) = "sp" | genRegRepr(GeneralReg (0w5, false), SZWord) = "bp" | genRegRepr(GeneralReg (0w6, false), SZWord) = "si" | genRegRepr(GeneralReg (0w7, false), SZWord) = "di" | genRegRepr(GeneralReg (reg, true), SZWord) = "r" ^ Int.toString(Word8.toInt reg +8) ^ "w" | genRegRepr _ = "unknown" (* Suppress warning because word values are not exhaustive. *) and fpRegRepr(FloatingPtReg n) = "fp" ^ Word8.toString n and xmmRegRepr(SSE2Reg n) = "xmm" ^ Word8.toString n fun regRepr(GenReg r) = genRegRepr (r, sz32_64) | regRepr(FPReg r) = fpRegRepr r | regRepr(XMMReg r) = xmmRegRepr r (* Install a pretty printer. This is simply for when this code is being run under the debugger. N.B. We need PolyML.PrettyString here. *) val () = PolyML.addPrettyPrinter(fn _ => fn _ => fn r => PolyML.PrettyString(regRepr r)) datatype argType = ArgGeneral | ArgFP (* Size of operand. OpSize64 is only valid in 64-bit mode. *) datatype opSize = OpSize32 | OpSize64 structure RegSet = struct (* Implement a register set as a bit mask. *) datatype regSet = RegSet of word fun singleton r = RegSet(0w1 << Word.fromInt(nReg r)) fun regSetUnion(RegSet r1, RegSet r2) = RegSet(Word.orb(r1, r2)) fun regSetIntersect(RegSet r1, RegSet r2) = RegSet(Word.andb(r1, r2)) local fun addReg(acc, n) = if n = regs then acc else addReg(regSetUnion(acc, singleton(regN n)), n+1) in val allRegisters = addReg(RegSet 0w0, 0) end val noRegisters = RegSet 0w0 fun inSet(r, rs) = regSetIntersect(singleton r, rs) <> noRegisters fun regSetMinus(RegSet s1, RegSet s2) = RegSet(Word.andb(s1, Word.notb s2)) val listToSet = List.foldl (fn(r, rs) => regSetUnion(singleton r, rs)) noRegisters local val regs = case targetArch of Native32Bit => [eax, ecx, edx, ebx, esi, edi] | Native64Bit => [eax, ecx, edx, ebx, esi, edi, r8, r9, r10, r11, r12, r13, r14] | ObjectId32Bit => [eax, ecx, edx, esi, edi, r8, r9, r10, r11, r12, r13, r14] in val generalRegisters = listToSet(map GenReg regs) end (* The floating point stack. Note that this excludes one item so it is always possible to load a value onto the top of the FP stack. *) val floatingPtRegisters = listToSet(map FPReg [fp0, fp1, fp2, fp3, fp4, fp5, fp6(*, fp7*)]) val sse2Registers = listToSet(map XMMReg [xmm0, xmm1, xmm2, xmm3, xmm4, xmm5, xmm6]) fun isAllRegs rs = rs = allRegisters fun setToList (RegSet regSet)= let fun testBit (n, bit, res) = if n = regs then res else testBit(n+1, bit << 0w1, if (regSet andb bit) <> 0w0 then regN n :: res else res) in testBit(0, 0w1, []) end val cardinality = List.length o setToList (* Choose one of the set. This chooses the least value which means that the ordering of the registers is significant. This is a hot-spot so is coded directly with the word operations. *) fun oneOf(RegSet regSet) = let fun find(n, bit) = if n = Word.fromInt regs then raise InternalError "oneOf: empty" else if Word.andb(bit, regSet) <> 0w0 then n else find(n+0w1, Word.<<(bit, 0w1)) in regN(Word.toInt(find(0w0, 0w1))) end fun regSetRepr regSet = let val regs = setToList regSet in "[" ^ String.concatWith "," (List.map regRepr regs) ^ "]" end (* Install a pretty printer for when this code is being debugged. *) val () = PolyML.addPrettyPrinter(fn _ => fn _ => fn r => PolyML.PrettyString(regSetRepr r)) end open RegSet datatype arithOp = ADD | OR (*|ADC | SBB*) | AND | SUB | XOR | CMP fun arithOpToWord ADD = 0w0: Word8.word | arithOpToWord OR = 0w1 | arithOpToWord AND = 0w4 | arithOpToWord SUB = 0w5 | arithOpToWord XOR = 0w6 | arithOpToWord CMP = 0w7 fun arithOpRepr ADD = "Add" | arithOpRepr OR = "Or" | arithOpRepr AND = "And" | arithOpRepr SUB = "Sub" | arithOpRepr XOR = "Xor" | arithOpRepr CMP = "Cmp" datatype shiftType = SHL | SHR | SAR fun shiftTypeToWord SHL = 0w4: Word8.word | shiftTypeToWord SHR = 0w5 | shiftTypeToWord SAR = 0w7 fun shiftTypeRepr SHL = "Shift Left Logical" | shiftTypeRepr SHR = "Shift Right Logical" | shiftTypeRepr SAR = "Shift Right Arithemetic" datatype repOps = CMPS8 | MOVS8 | MOVS32 | STOS8 | STOS32 | MOVS64 | STOS64 fun repOpsToWord CMPS8 = 0wxa6: Word8.word | repOpsToWord MOVS8 = 0wxa4 | repOpsToWord MOVS32 = 0wxa5 | repOpsToWord MOVS64 = 0wxa5 (* Plus Rex.w *) | repOpsToWord STOS8 = 0wxaa | repOpsToWord STOS32 = 0wxab | repOpsToWord STOS64 = 0wxab (* Plus Rex.w *) fun repOpsRepr CMPS8 = "CompareBytes" | repOpsRepr MOVS8 = "MoveBytes" | repOpsRepr MOVS32 = "MoveWords32" | repOpsRepr MOVS64 = "MoveWords64" | repOpsRepr STOS8 = "StoreBytes" | repOpsRepr STOS32 = "StoreWords32" | repOpsRepr STOS64 = "StoreWords64" datatype fpOps = FADD | FMUL | FCOM | FCOMP | FSUB | FSUBR | FDIV | FDIVR fun fpOpToWord FADD = 0w0: Word8.word | fpOpToWord FMUL = 0w1 | fpOpToWord FCOM = 0w2 | fpOpToWord FCOMP = 0w3 | fpOpToWord FSUB = 0w4 | fpOpToWord FSUBR = 0w5 | fpOpToWord FDIV = 0w6 | fpOpToWord FDIVR = 0w7 fun fpOpRepr FADD = "FPAdd" | fpOpRepr FMUL = "FPMultiply" | fpOpRepr FCOM = "FPCompare" | fpOpRepr FCOMP = "FPCompareAndPop" | fpOpRepr FSUB = "FPSubtract" | fpOpRepr FSUBR = "FPReverseSubtract" | fpOpRepr FDIV = "FPDivide" | fpOpRepr FDIVR = "FPReverseDivide" datatype fpUnaryOps = FCHS | FABS | FLD1 | FLDZ fun fpUnaryToWords FCHS = {rm=0w0:Word8.word, nnn=0w4: Word8.word} | fpUnaryToWords FABS = {rm=0w1, nnn=0w4} | fpUnaryToWords FLD1 = {rm=0w0, nnn=0w5} | fpUnaryToWords FLDZ = {rm=0w6, nnn=0w5} fun fpUnaryRepr FCHS = "FPChangeSign" | fpUnaryRepr FABS = "FPAbs" | fpUnaryRepr FLD1 = "FPLoadOne" | fpUnaryRepr FLDZ = "FPLoadZero" datatype branchOps = JO | JNO | JE | JNE | JL | JGE | JLE | JG | JB | JNB | JNA | JA | JP | JNP fun branchOpToWord JO = 0wx0: Word8.word | branchOpToWord JNO = 0wx1 | branchOpToWord JB = 0wx2 | branchOpToWord JNB = 0wx3 | branchOpToWord JE = 0wx4 | branchOpToWord JNE = 0wx5 | branchOpToWord JNA = 0wx6 | branchOpToWord JA = 0wx7 | branchOpToWord JP = 0wxa | branchOpToWord JNP = 0wxb | branchOpToWord JL = 0wxc | branchOpToWord JGE = 0wxd | branchOpToWord JLE = 0wxe | branchOpToWord JG = 0wxf fun branchOpRepr JO = "Overflow" | branchOpRepr JNO = "NotOverflow" | branchOpRepr JE = "Equal" | branchOpRepr JNE = "NotEqual" | branchOpRepr JL = "Less" | branchOpRepr JGE = "GreaterOrEqual" | branchOpRepr JLE = "LessOrEqual" | branchOpRepr JG = "Greater" | branchOpRepr JB = "Before" | branchOpRepr JNB= "NotBefore" | branchOpRepr JNA = "NotAfter" | branchOpRepr JA = "After" | branchOpRepr JP = "Parity" | branchOpRepr JNP = "NoParity" (* Invert a test. This is used if we want to change the sense of a test from jumping if the condition is true to jumping if it is false. *) fun invertTest JE = JNE | invertTest JNE = JE | invertTest JA = JNA | invertTest JB = JNB | invertTest JNA = JA | invertTest JNB = JB | invertTest JL = JGE | invertTest JG = JLE | invertTest JLE = JG | invertTest JGE = JL | invertTest JO = JNO | invertTest JNO = JO | invertTest JP = JNP | invertTest JNP = JP datatype sse2Operations = SSE2MoveDouble | SSE2MoveFloat | SSE2CompDouble | SSE2AddDouble | SSE2SubDouble | SSE2MulDouble | SSE2DivDouble | SSE2Xor | SSE2And | SSE2FloatToDouble | SSE2DoubleToFloat | SSE2CompSingle | SSE2AddSingle | SSE2SubSingle | SSE2MulSingle | SSE2DivSingle fun sse2OpRepr SSE2MoveDouble = "SSE2MoveDouble" | sse2OpRepr SSE2MoveFloat = "SSE2MoveFloat" | sse2OpRepr SSE2CompDouble = "SSE2CompDouble" | sse2OpRepr SSE2AddDouble = "SSE2AddDouble" | sse2OpRepr SSE2SubDouble = "SSE2SubDouble" | sse2OpRepr SSE2MulDouble = "SSE2MulDouble" | sse2OpRepr SSE2DivDouble = "SSE2DivDouble" | sse2OpRepr SSE2Xor = "SSE2Xor" | sse2OpRepr SSE2And = "SSE2And" | sse2OpRepr SSE2CompSingle = "SSE2CompSingle" | sse2OpRepr SSE2AddSingle = "SSE2AddSingle" | sse2OpRepr SSE2SubSingle = "SSE2SubSingle" | sse2OpRepr SSE2MulSingle = "SSE2MulSingle" | sse2OpRepr SSE2DivSingle = "SSE2DivSingle" | sse2OpRepr SSE2FloatToDouble = "SSE2FloatToDouble" | sse2OpRepr SSE2DoubleToFloat = "SSE2DoubleToFloat" (* Primary opCodes. N.B. only opCodes actually used are listed here. If new instruction are added check they will be handled by the run-time system in the event of trap. *) datatype opCode = Group1_8_A32 | Group1_8_A64 | Group1_32_A32 | Group1_32_A64 | Group1_8_a | JMP_8 | JMP_32 | CALL_32 | MOVL_A_R32 | MOVL_A_R64 | MOVL_R_A32 | MOVL_R_A64 | MOVL_R_A16 | MOVB_R_A32 | MOVB_R_A64 of {forceRex: bool} | PUSH_R of Word8.word | POP_R of Word8.word | Group5 | NOP | LEAL32 | LEAL64 | MOVL_32_R of Word8.word | MOVL_64_R of Word8.word | MOVL_32_A32 | MOVL_32_A64 | MOVB_8_A | POP_A | RET | RET_16 | CondJump of branchOps | CondJump32 of branchOps | SetCC of branchOps | Arith32 of arithOp * Word8.word | Arith64 of arithOp * Word8.word | Group3_A32 | Group3_A64 | Group3_a | Group2_8_A32 | Group2_8_A64 | Group2_CL_A32 | Group2_CL_A64 | Group2_1_A32 | Group2_1_A64 | PUSH_8 | PUSH_32 | TEST_ACC8 | LOCK_XADD32 | LOCK_XADD64 | FPESC of Word8.word | XCHNG32 | XCHNG64 | REP (* Rep prefix *) | MOVZB (* Needs escape code. *) | MOVZW (* Needs escape code. *) | MOVSXB32 (* Needs escape code. *) | MOVSXW32 (* Needs escape code. *) | MOVSXB64 (* Needs escape code. *) | MOVSXW64 (* Needs escape code. *) | IMUL32 (* Needs escape code. *) | IMUL64 (* Needs escape code. *) | SSE2StoreSingle (* movss with memory destination - needs escape sequence. *) | SSE2StoreDouble (* movsd with memory destination - needs escape sequence. *) | CQO_CDQ32 (* Sign extend before divide.. *) | CQO_CDQ64 (* Sign extend before divide.. *) | SSE2Ops of sse2Operations (* SSE2 instructions. *) | CVTSI2SD32 | CVTSI2SD64 | HLT (* End of code marker. *) | IMUL_C8_32 | IMUL_C8_64 | IMUL_C32_32 | IMUL_C32_64 | MOVDFromXMM (* move 32 bit value from XMM to general reg. *) | MOVQToXMM (* move 64 bit value from general reg.to XMM *) | PSRLDQ (* Shift XMM register *) | LDSTMXCSR | CVTSD2SI32 (* Double to 32-bit int *) | CVTSD2SI64 (* Double to 64-bit int *) | CVTSS2SI32 (* Single to 32-bit int *) | CVTSS2SI64 (* Single to 64-bit int *) | CVTTSD2SI32 (* Double to 32-bit int - truncate towards zero *) | CVTTSD2SI64 (* Double to 64-bit int - truncate towards zero *) | CVTTSS2SI32 (* Single to 32-bit int - truncate towards zero *) | CVTTSS2SI64 (* Single to 64-bit int - truncate towards zero *) | MOVSXD | CMOV32 of branchOps | CMOV64 of branchOps fun opToInt Group1_8_A32 = 0wx83 | opToInt Group1_8_A64 = 0wx83 | opToInt Group1_32_A32 = 0wx81 | opToInt Group1_32_A64 = 0wx81 | opToInt Group1_8_a = 0wx80 | opToInt JMP_8 = 0wxeb | opToInt JMP_32 = 0wxe9 | opToInt CALL_32 = 0wxe8 | opToInt MOVL_A_R32 = 0wx8b | opToInt MOVL_A_R64 = 0wx8b | opToInt MOVL_R_A32 = 0wx89 | opToInt MOVL_R_A64 = 0wx89 | opToInt MOVL_R_A16 = 0wx89 (* Also has an OPSIZE prefix. *) | opToInt MOVB_R_A32 = 0wx88 | opToInt (MOVB_R_A64 _) = 0wx88 | opToInt (PUSH_R reg) = 0wx50 + reg | opToInt (POP_R reg) = 0wx58 + reg | opToInt Group5 = 0wxff | opToInt NOP = 0wx90 | opToInt LEAL32 = 0wx8d | opToInt LEAL64 = 0wx8d | opToInt (MOVL_32_R reg) = 0wxb8 + reg | opToInt (MOVL_64_R reg) = 0wxb8 + reg | opToInt MOVL_32_A32 = 0wxc7 | opToInt MOVL_32_A64 = 0wxc7 | opToInt MOVB_8_A = 0wxc6 | opToInt POP_A = 0wx8f | opToInt RET = 0wxc3 | opToInt RET_16 = 0wxc2 | opToInt (CondJump opc) = 0wx70 + branchOpToWord opc | opToInt (CondJump32 opc) = 0wx80 + branchOpToWord opc (* Needs 0F prefix *) | opToInt (SetCC opc) = 0wx90 + branchOpToWord opc (* Needs 0F prefix *) | opToInt (Arith32 (ao,dw)) = arithOpToWord ao * 0w8 + dw | opToInt (Arith64 (ao,dw)) = arithOpToWord ao * 0w8 + dw | opToInt Group3_A32 = 0wxf7 | opToInt Group3_A64 = 0wxf7 | opToInt Group3_a = 0wxf6 | opToInt Group2_8_A32 = 0wxc1 | opToInt Group2_8_A64 = 0wxc1 | opToInt Group2_1_A32 = 0wxd1 | opToInt Group2_1_A64 = 0wxd1 | opToInt Group2_CL_A32 = 0wxd3 | opToInt Group2_CL_A64 = 0wxd3 | opToInt PUSH_8 = 0wx6a | opToInt PUSH_32 = 0wx68 | opToInt TEST_ACC8 = 0wxa8 | opToInt LOCK_XADD32 = 0wxC1 (* Needs lock and escape prefixes. *) | opToInt LOCK_XADD64 = 0wxC1 (* Needs lock and escape prefixes. *) | opToInt (FPESC n) = 0wxD8 orb8 n | opToInt XCHNG32 = 0wx87 | opToInt XCHNG64 = 0wx87 | opToInt REP = 0wxf3 | opToInt MOVZB = 0wxb6 (* Needs escape code. *) | opToInt MOVZW = 0wxb7 (* Needs escape code. *) | opToInt MOVSXB32 = 0wxbe (* Needs escape code. *) | opToInt MOVSXW32 = 0wxbf (* Needs escape code. *) | opToInt MOVSXB64 = 0wxbe (* Needs escape code. *) | opToInt MOVSXW64 = 0wxbf (* Needs escape code. *) | opToInt IMUL32 = 0wxaf (* Needs escape code. *) | opToInt IMUL64 = 0wxaf (* Needs escape code. *) | opToInt SSE2StoreSingle = 0wx11 (* Needs F3 0F escape. *) | opToInt SSE2StoreDouble = 0wx11 (* Needs F2 0F escape. *) | opToInt CQO_CDQ32 = 0wx99 | opToInt CQO_CDQ64 = 0wx99 | opToInt (SSE2Ops SSE2MoveDouble) = 0wx10 (* Needs F2 0F escape. *) | opToInt (SSE2Ops SSE2MoveFloat) = 0wx10 (* Needs F3 0F escape. *) | opToInt (SSE2Ops SSE2CompDouble) = 0wx2E (* Needs 66 0F escape. *) | opToInt (SSE2Ops SSE2AddDouble) = 0wx58 (* Needs F2 0F escape. *) | opToInt (SSE2Ops SSE2SubDouble) = 0wx5c (* Needs F2 0F escape. *) | opToInt (SSE2Ops SSE2MulDouble) = 0wx59 (* Needs F2 0F escape. *) | opToInt (SSE2Ops SSE2DivDouble) = 0wx5e (* Needs F2 0F escape. *) | opToInt (SSE2Ops SSE2CompSingle) = 0wx2E (* Needs 0F escape. *) | opToInt (SSE2Ops SSE2AddSingle) = 0wx58 (* Needs F3 0F escape. *) | opToInt (SSE2Ops SSE2SubSingle) = 0wx5c (* Needs F3 0F escape. *) | opToInt (SSE2Ops SSE2MulSingle) = 0wx59 (* Needs F3 0F escape. *) | opToInt (SSE2Ops SSE2DivSingle) = 0wx5e (* Needs F3 0F escape. *) | opToInt (SSE2Ops SSE2And) = 0wx54 (* Needs 66 0F escape. *) | opToInt (SSE2Ops SSE2Xor) = 0wx57 (* Needs 66 0F escape. *) | opToInt (SSE2Ops SSE2FloatToDouble) = 0wx5A (* Needs F3 0F escape. *) | opToInt (SSE2Ops SSE2DoubleToFloat) = 0wx5A (* Needs F2 0F escape. *) | opToInt CVTSI2SD32 = 0wx2a (* Needs F2 0F escape. *) | opToInt CVTSI2SD64 = 0wx2a (* Needs F2 0F escape. *) | opToInt HLT = 0wxf4 | opToInt IMUL_C8_32 = 0wx6b | opToInt IMUL_C8_64 = 0wx6b | opToInt IMUL_C32_32 = 0wx69 | opToInt IMUL_C32_64 = 0wx69 | opToInt MOVDFromXMM = 0wx7e (* Needs 66 0F escape. *) | opToInt MOVQToXMM = 0wx6e (* Needs 66 0F escape. *) | opToInt PSRLDQ = 0wx73 (* Needs 66 0F escape. *) | opToInt LDSTMXCSR = 0wxae (* Needs 0F prefix. *) | opToInt CVTSD2SI32 = 0wx2d (* Needs F2 0F prefix. *) | opToInt CVTSD2SI64 = 0wx2d (* Needs F2 0F prefix and rex.w. *) | opToInt CVTSS2SI32 = 0wx2d (* Needs F3 0F prefix. *) | opToInt CVTSS2SI64 = 0wx2d (* Needs F3 0F prefix and rex.w. *) | opToInt CVTTSD2SI32 = 0wx2c (* Needs F2 0F prefix. *) | opToInt CVTTSD2SI64 = 0wx2c (* Needs F2 0F prefix. *) | opToInt CVTTSS2SI32 = 0wx2c (* Needs F3 0F prefix. *) | opToInt CVTTSS2SI64 = 0wx2c (* Needs F3 0F prefix and rex.w. *) | opToInt MOVSXD = 0wx63 | opToInt (CMOV32 opc) = 0wx40 + branchOpToWord opc (* Needs 0F prefix *) | opToInt (CMOV64 opc) = 0wx40 + branchOpToWord opc (* Needs 0F prefix and rex.w *) datatype mode = Based0 (* mod = 0 *) | Based8 (* mod = 1 *) | Based32 (* mod = 2 *) | Register (* mod = 3 *) ; (* Put together the three fields which make up the mod r/m byte. *) fun modrm (md : mode, rg: Word8.word, rm : Word8.word) : Word8.word = let val _ = if rg > 0w7 then raise InternalError "modrm: bad rg" else () val _ = if rm > 0w7 then raise InternalError "modrm: bad rm" else () val modField: Word8.word = case md of Based0 => 0w0 | Based8 => 0w1 | Based32 => 0w2 | Register => 0w3 in (modField <<- 0w6) orb8 (rg <<- 0w3) orb8 rm end (* REX prefix *) fun rex {w,r,x,b} = 0wx40 orb8 (if w then 0w8 else 0w0) orb8 (if r then 0w4 else 0w0) orb8 (if x then 0w2 else 0w0) orb8 (if b then 0w1 else 0w0) (* The X86 has the option to include an index register and to scale it. *) datatype indexType = NoIndex | Index1 of genReg | Index2 of genReg | Index4 of genReg | Index8 of genReg (* Lock, Opsize and REPNE prefixes come before the REX. *) fun opcodePrefix LOCK_XADD32 = [0wxF0] (* Requires LOCK prefix. *) | opcodePrefix LOCK_XADD64 = [0wxF0] (* Requires LOCK prefix. *) | opcodePrefix MOVL_R_A16 = [0wx66] (* Requires OPSIZE prefix. *) | opcodePrefix SSE2StoreSingle = [0wxf3] | opcodePrefix SSE2StoreDouble = [0wxf2] | opcodePrefix(SSE2Ops SSE2CompDouble) = [0wx66] | opcodePrefix(SSE2Ops SSE2And) = [0wx66] | opcodePrefix(SSE2Ops SSE2Xor) = [0wx66] | opcodePrefix(SSE2Ops SSE2CompSingle) = [] (* No prefix *) | opcodePrefix(SSE2Ops SSE2MoveDouble) = [0wxf2] | opcodePrefix(SSE2Ops SSE2AddDouble) = [0wxf2] | opcodePrefix(SSE2Ops SSE2SubDouble) = [0wxf2] | opcodePrefix(SSE2Ops SSE2MulDouble) = [0wxf2] | opcodePrefix(SSE2Ops SSE2DivDouble) = [0wxf2] | opcodePrefix(SSE2Ops SSE2DoubleToFloat) = [0wxf2] | opcodePrefix(SSE2Ops SSE2MoveFloat) = [0wxf3] | opcodePrefix(SSE2Ops SSE2AddSingle) = [0wxf3] | opcodePrefix(SSE2Ops SSE2SubSingle) = [0wxf3] | opcodePrefix(SSE2Ops SSE2MulSingle) = [0wxf3] | opcodePrefix(SSE2Ops SSE2DivSingle) = [0wxf3] | opcodePrefix(SSE2Ops SSE2FloatToDouble) = [0wxf3] | opcodePrefix CVTSI2SD32 = [0wxf2] | opcodePrefix CVTSI2SD64 = [0wxf2] | opcodePrefix MOVDFromXMM = [0wx66] | opcodePrefix MOVQToXMM = [0wx66] | opcodePrefix PSRLDQ = [0wx66] | opcodePrefix CVTSD2SI32 = [0wxf2] | opcodePrefix CVTSD2SI64 = [0wxf2] | opcodePrefix CVTSS2SI32 = [0wxf3] | opcodePrefix CVTSS2SI64 = [0wxf3] | opcodePrefix CVTTSD2SI32 = [0wxf2] | opcodePrefix CVTTSD2SI64 = [0wxf2] | opcodePrefix CVTTSS2SI32 = [0wxf3] | opcodePrefix CVTTSS2SI64 = [0wxf3] | opcodePrefix _ = [] (* A few instructions require an escape. Escapes come after the REX. *) fun escapePrefix MOVZB = [0wx0f] | escapePrefix MOVZW = [0wx0f] | escapePrefix MOVSXB32 = [0wx0f] | escapePrefix MOVSXW32 = [0wx0f] | escapePrefix MOVSXB64 = [0wx0f] | escapePrefix MOVSXW64 = [0wx0f] | escapePrefix LOCK_XADD32 = [0wx0f] | escapePrefix LOCK_XADD64 = [0wx0f] | escapePrefix IMUL32 = [0wx0f] | escapePrefix IMUL64 = [0wx0f] | escapePrefix(CondJump32 _) = [0wx0f] | escapePrefix(SetCC _) = [0wx0f] | escapePrefix SSE2StoreSingle = [0wx0f] | escapePrefix SSE2StoreDouble = [0wx0f] | escapePrefix(SSE2Ops _) = [0wx0f] | escapePrefix CVTSI2SD32 = [0wx0f] | escapePrefix CVTSI2SD64 = [0wx0f] | escapePrefix MOVDFromXMM = [0wx0f] | escapePrefix MOVQToXMM = [0wx0f] | escapePrefix PSRLDQ = [0wx0f] | escapePrefix LDSTMXCSR = [0wx0f] | escapePrefix CVTSD2SI32 = [0wx0f] | escapePrefix CVTSD2SI64 = [0wx0f] | escapePrefix CVTSS2SI32 = [0wx0f] | escapePrefix CVTSS2SI64 = [0wx0f] | escapePrefix CVTTSD2SI32 = [0wx0f] | escapePrefix CVTTSD2SI64 = [0wx0f] | escapePrefix CVTTSS2SI32 = [0wx0f] | escapePrefix CVTTSS2SI64 = [0wx0f] | escapePrefix(CMOV32 _) = [0wx0f] | escapePrefix(CMOV64 _) = [0wx0f] | escapePrefix _ = [] (* Generate an opCode byte after doing any pending operations. *) fun opCodeBytes(opb:opCode, rx) = let val rexByte = case rx of NONE => [] | SOME rxx => if hostIsX64 then [rex rxx] else raise InternalError "opCodeBytes: rex prefix in 32 bit mode"; in opcodePrefix opb @ rexByte @ escapePrefix opb @ [opToInt opb] end fun rexByte(opb, rrX, rbX, riX) = let (* We need a rex prefix if we need to set the length to 64-bit. *) val need64bit = case opb of Group1_8_A64 => true (* Arithmetic operations - must be 64-bit *) | Group1_32_A64 => true (* Arithmetic operations - must be 64-bit *) | Group2_1_A64 => true (* 1-bit shifts - must be 64-bit *) | Group2_8_A64 => true (* n-bit shifts - must be 64-bit *) | Group2_CL_A64 => true (* Shifts by value in CL *) | Group3_A64 => true (* Test, Not, Mul etc. *) | Arith64 (_, _) => true | MOVL_A_R64 => true (* Needed *) | MOVL_R_A64 => true (* Needed *) | XCHNG64 => true | LEAL64 => true (* Needed to ensure the result is 64-bits *) | MOVL_64_R _ => true (* Needed *) | MOVL_32_A64 => true (* Needed *) | IMUL64 => true (* Needed to ensure the result is 64-bits *) | LOCK_XADD64 => true (* Needed to ensure the result is 64-bits *) | CQO_CDQ64 => true (* It's only CQO if there's a Rex prefix. *) | CVTSI2SD64 => true (* This affects the size of the integer source. *) | IMUL_C8_64 => true | IMUL_C32_64 => true | MOVQToXMM => true | CVTSD2SI64 => true (* This affects the size of the integer source. *) | CVTSS2SI64 => true | CVTTSD2SI64 => true | CVTTSS2SI64 => true | MOVSXD => true | CMOV64 _ => true | MOVSXB64 => true | MOVSXW64 => true (* Group5 - We only use 2/4/6 and they don't need prefix *) | _ => false (* If we are using MOVB_R_A with SIL or DIL we need to force a REX prefix. That's only possible in 64-bit mode. This also applies with Test and SetCC but they are dealt with elsewhere. *) val forceRex = case opb of MOVB_R_A64 {forceRex=true} => true (* This is allowed in X86/64 but not in X86/32. *) | _ => false in if need64bit orelse rrX orelse rbX orelse riX orelse forceRex then [rex{w=need64bit, r=rrX, b=rbX, x = riX}] else [] end (* Register/register operation. *) fun opReg(opb:opCode, (*dest*)GeneralReg(rrC, rrX), (*source*)GeneralReg(rbC, rbX)) = let val pref = opcodePrefix opb (* Any opsize or lock prefix. *) val rex = rexByte(opb, rrX, rbX, false) val esc = escapePrefix opb (* Generate the ESCAPE code if needed. *) val opc = opToInt opb val mdrm = modrm(Register, rrC, rbC) in pref @ rex @ esc @ [opc, mdrm] end (* Operations on a register where the second "register" is actually an operation code. *) fun opRegPlus2(opb:opCode, rd: genReg, op2: Word8.word) = let val (rrC, rrX) = getReg rd val pref = opcodePrefix opb (* Any opsize or lock prefix. *) val rex = rexByte(opb, false, rrX, false) val opc = opToInt opb val mdrm = modrm(Register, op2, rrC) in pref @ rex @ [opc, mdrm] end local (* General instruction form with modrm and optional sib bytes. rb is an option since the base register may be omitted. This is used with LEA to tag integers. *) fun opIndexedGen (opb:opCode, offset: LargeInt.int, rb: genReg option, ri: indexType, (rrC, rrX)) = let (* Base encoding. (Based0, 0w5) means "no base" so if we need ebp as the base we have to use Based8 at least. *) val (offsetCode, rbC, rbX) = case rb of NONE => (Based0, 0w5 (* no base register *), false) | SOME rb => let val (rbC, rbX) = getReg rb val base = if offset = 0 andalso rbC <> 0wx5 (* Can't use ebp with Based0 *) then Based0 (* no disp field *) else if is8BitL offset then Based8 (* use 8-bit disp field *) else Based32 (* use 32-bit disp field *) in (base, rbC, rbX) end (* Index coding. esp can't be used as an index so (0w4, false) means "no index". But r12 (0w4, true) CAN be. *) val ((riC, riX), scaleFactor) = case ri of NoIndex => ((0w4, false), 0w0) | Index1 i => (getReg i, 0w0) | Index2 i => (getReg i, 0w1) | Index4 i => (getReg i, 0w2) | Index8 i => (getReg i, 0w3) (* If the base register is esp or r12 we have to use a sib byte even if there's no index. That's because 0w4 as a base register means "there's a SIB byte". *) val modRmAndOptionalSib = if rbC = 0w4 (* Code for esp and r12 *) orelse riC <> 0w4 orelse riX then let val mdrm = modrm(offsetCode, rrC, 0w4 (* s-i-b *)) val sibByte = (scaleFactor <<- 0w6) orb8 (riC <<- 0w3) orb8 rbC in [mdrm, sibByte] end else [modrm(offsetCode, rrC, rbC)] (* Generate the disp field (if any) *) val dispField = case (offsetCode, rb) of (Based8, _) => [Word8.fromLargeInt offset] | (Based32, _) => int32Signed offset | (_, NONE) => (* 32 bit absolute used as base *) int32Signed offset | _ => [] in opcodePrefix opb @ rexByte(opb, rrX, rbX, riX) @ escapePrefix opb @ opToInt opb :: modRmAndOptionalSib @ dispField end in fun opEA(opb, offset, rb, r) = opIndexedGen(opb, offset, SOME rb, NoIndex, getReg r) (* Generate a opcode plus a second modrm byte but where the "register" field in the modrm byte is actually a code. *) and opPlus2(opb, offset, rb, op2) = opIndexedGen(opb, offset, SOME rb, NoIndex, (op2, false)) and opIndexedPlus2(opb, offset, rb, ri, op2) = opIndexedGen(opb, offset, SOME rb, ri, (op2, false)) fun opIndexed (opb, offset, rb, ri, rd) = opIndexedGen(opb, offset, rb, ri, getReg rd) fun opAddress(opb, offset, rb, ri, rd) = opIndexedGen (opb, offset, SOME rb, ri, getReg rd) and mMXAddress(opb, offset, rb, ri, SSE2Reg rrC) = opIndexedGen(opb, offset, SOME rb, ri, (rrC, false)) and opAddressPlus2(opb, offset, rb, ri, op2) = opIndexedGen(opb, offset, SOME rb, ri, (op2, false)) end (* An operation with an operand that needs to go in the constant area, or in the case of native 32-bit, where the constant is stored in an object and the address of the object is inline. This just puts in the instruction and the address. The details of the constant are dealt with in putConst. *) fun opConstantOperand(opb, (*dest*)GeneralReg(rrC, rrX)) = let val pref = opcodePrefix opb (* Any opsize or lock prefix. *) val rex = rexByte(opb, rrX, false, false) val esc = escapePrefix opb (* Generate the ESCAPE code if needed. *) val opc = opToInt opb val mdrm = modrm(Based0, rrC, 0w5 (* PC-relative or absolute *)) in pref @ rex @ esc @ [opc, mdrm] @ int32Signed(tag 0) end fun immediateOperand (opn: arithOp, rd: genReg, imm: LargeInt.int, opSize) = if is8BitL imm then (* Can use one byte immediate *) opRegPlus2(case opSize of OpSize64 => Group1_8_A64 | OpSize32 => Group1_8_A32, rd, arithOpToWord opn) @ [Word8.fromLargeInt imm] else if is32bit imm then (* Need 32 bit immediate. *) opRegPlus2(case opSize of OpSize64 => Group1_32_A64 | OpSize32 => Group1_32_A32, rd, arithOpToWord opn) @ int32Signed imm else (* It won't fit in the immediate; put it in the non-address area. *) let val opc = case opSize of OpSize64 => Arith64 | OpSize32 => Arith32 in opConstantOperand(opc(opn, 0w3 (* r/m to reg *)), rd) end fun arithOpReg(opn: arithOp, rd: genReg, rs: genReg, opIs64) = opReg ((if opIs64 then Arith64 else Arith32) (opn, 0w3 (* r/m to reg *)), rd, rs) type handlerLab = addrs ref fun floatingPtOp{escape, md, nnn, rm} = opCodeBytes(FPESC escape, NONE) @ [(md <<- 0w6) orb8 (nnn <<- 0w3) orb8 rm] datatype trapEntries = StackOverflowCall | StackOverflowCallEx | HeapOverflowCall (* RTS call. We need to save any registers that may contain addresses to the stack. All the registers are preserved but not seen by the GC. *) fun rtsCall(rtsEntry, regSet) = let val entry = case rtsEntry of StackOverflowCall => memRegStackOverflowCall | StackOverflowCallEx => memRegStackOverflowCallEx | HeapOverflowCall => memRegHeapOverflowCall val regSet = List.foldl(fn (r, a) => (0w1 << Word.fromInt(nReg(GenReg r))) orb a) 0w0 regSet val callInstr = opPlus2(Group5, LargeInt.fromInt entry, ebp, 0w2 (* call *)) val regSetInstr = if regSet >= 0w256 then [0wxca, (* This is actually a FAR RETURN *) wordToWord8 regSet, (* Low byte*) wordToWord8 (regSet >> 0w8) (* High byte*)] else if regSet <> 0w0 then [0wxcd, (* This is actually INT n *) wordToWord8 regSet] else [] in callInstr @ regSetInstr end (* Operations. *) type cases = word * label type memoryAddress = { base: genReg, offset: int, index: indexType } datatype 'reg regOrMemoryArg = RegisterArg of 'reg | MemoryArg of memoryAddress | NonAddressConstArg of LargeInt.int | AddressConstArg of machineWord datatype moveSize = Move64 | Move32 | Move8 | Move16 | Move32X64 | Move8X32 | Move8X64 | Move16X32 | Move16X64 and fpSize = SinglePrecision | DoublePrecision datatype operation = Move of { source: genReg regOrMemoryArg, destination: genReg regOrMemoryArg, moveSize: moveSize } | PushToStack of genReg regOrMemoryArg | PopR of genReg | ArithToGenReg of { opc: arithOp, output: genReg, source: genReg regOrMemoryArg, opSize: opSize } | ArithMemConst of { opc: arithOp, address: memoryAddress, source: LargeInt.int, opSize: opSize } | ArithMemLongConst of { opc: arithOp, address: memoryAddress, source: machineWord } | ArithByteMemConst of { opc: arithOp, address: memoryAddress, source: Word8.word } | ShiftConstant of { shiftType: shiftType, output: genReg, shift: Word8.word, opSize: opSize } | ShiftVariable of { shiftType: shiftType, output: genReg, opSize: opSize } (* Shift amount is in ecx *) | ConditionalBranch of { test: branchOps, label: label } | SetCondition of { output: genReg, test: branchOps } | LoadAddress of { output: genReg, offset: int, base: genReg option, index: indexType, opSize: opSize } | TestByteBits of { arg: genReg regOrMemoryArg, bits: Word8.word } | CallRTS of {rtsEntry: trapEntries, saveRegs: genReg list } | AllocStore of { size: int, output: genReg, saveRegs: genReg list } | AllocStoreVariable of { size: genReg, output: genReg, saveRegs: genReg list } | StoreInitialised | CallAddress of genReg regOrMemoryArg | JumpAddress of genReg regOrMemoryArg | ReturnFromFunction of int | RaiseException of { workReg: genReg } | UncondBranch of label | ResetStack of { numWords: int, preserveCC: bool } | JumpLabel of label | LoadLabelAddress of { label: label, output: genReg } | RepeatOperation of repOps | DivideAccR of {arg: genReg, isSigned: bool, opSize: opSize } | DivideAccM of {base: genReg, offset: int, isSigned: bool, opSize: opSize } | AtomicXAdd of {address: memoryAddress, output: genReg, opSize: opSize } | FPLoadFromMemory of { address: memoryAddress, precision: fpSize } | FPLoadFromFPReg of { source: fpReg, lastRef: bool } | FPLoadFromConst of { constant: machineWord, precision: fpSize } | FPStoreToFPReg of { output: fpReg, andPop: bool } | FPStoreToMemory of { address: memoryAddress, precision: fpSize, andPop: bool } | FPArithR of { opc: fpOps, source: fpReg } | FPArithConst of { opc: fpOps, source: machineWord, precision: fpSize } | FPArithMemory of { opc: fpOps, base: genReg, offset: int, precision: fpSize } | FPUnary of fpUnaryOps | FPStatusToEAX | FPLoadInt of { base: genReg, offset: int, opSize: opSize } | FPFree of fpReg | MultiplyR of { source: genReg regOrMemoryArg, output: genReg, opSize: opSize } | XMMArith of { opc: sse2Operations, source: xmmReg regOrMemoryArg, output: xmmReg } | XMMStoreToMemory of { toStore: xmmReg, address: memoryAddress, precision: fpSize } | XMMConvertFromInt of { source: genReg, output: xmmReg, opSize: opSize } | SignExtendForDivide of opSize | XChng of { reg: genReg, arg: genReg regOrMemoryArg, opSize: opSize } | Negative of { output: genReg, opSize: opSize } | JumpTable of { cases: label list, jumpSize: jumpSize ref } | IndexedJumpCalc of { addrReg: genReg, indexReg: genReg, jumpSize: jumpSize ref } | MoveXMMRegToGenReg of { source: xmmReg, output: genReg } | MoveGenRegToXMMReg of { source: genReg, output: xmmReg } | XMMShiftRight of { output: xmmReg, shift: Word8.word } | FPLoadCtrlWord of memoryAddress (* Load FP control word. *) | FPStoreCtrlWord of memoryAddress (* Store FP control word. *) | XMMLoadCSR of memoryAddress (* Load combined control/status word. *) | XMMStoreCSR of memoryAddress (* Store combined control/status word. *) | FPStoreInt of memoryAddress | XMMStoreInt of { source: xmmReg regOrMemoryArg, output: genReg, precision: fpSize, isTruncate: bool } | CondMove of { test: branchOps, output: genReg, source: genReg regOrMemoryArg, opSize: opSize } | LoadAbsolute of { destination: genReg, value: machineWord } and jumpSize = JumpSize2 | JumpSize8 type operations = operation list fun printOperation(operation, stream) = let fun printGReg r = stream(genRegRepr(r, sz32_64)) val printFPReg = stream o fpRegRepr and printXMMReg = stream o xmmRegRepr fun printBaseOffset(b, x, i) = ( stream(Int.toString i); stream "("; printGReg b; stream ")"; case x of NoIndex => () | Index1 x => (stream "["; printGReg x; stream "]") | Index2 x => (stream "["; printGReg x; stream "*2]") | Index4 x => (stream "["; printGReg x; stream "*4]") | Index8 x => (stream "["; printGReg x; stream "*8]") ) fun printMemAddress({ base, offset, index }) = printBaseOffset(base, index, offset) fun printRegOrMemoryArg printReg (RegisterArg r) = printReg r | printRegOrMemoryArg _ (MemoryArg{ base, offset, index }) = printBaseOffset(base, index, offset) | printRegOrMemoryArg _ (NonAddressConstArg c) = stream(LargeInt.toString c) | printRegOrMemoryArg _ (AddressConstArg c) = stream(Address.stringOfWord c) fun printOpSize OpSize32 = "32" | printOpSize OpSize64 = "64" in case operation of Move { source, destination, moveSize } => ( case moveSize of Move64 => stream "Move64 " | Move32 => stream "Move32 " | Move8 => stream "Move8 " | Move16 => stream "Move16 " | Move32X64 => stream "Move32X64 " | Move8X32 => stream "Move8X32 " | Move8X64 => stream "Move8X64 " | Move16X32 => stream "Move16X32 " | Move16X64 => stream "Move16X64 "; printRegOrMemoryArg printGReg destination; stream " <= "; printRegOrMemoryArg printGReg source ) | ArithToGenReg { opc, output, source, opSize } => (stream (arithOpRepr opc); stream "RR"; stream(printOpSize opSize); stream " "; printGReg output; stream " <= "; printRegOrMemoryArg printGReg source ) | ArithMemConst { opc, address, source, opSize } => ( stream (arithOpRepr opc); stream "MC"; stream(printOpSize opSize); stream " "; printMemAddress address; stream " "; stream(LargeInt.toString source) ) | ArithMemLongConst { opc, address, source } => ( stream (arithOpRepr opc ^ "MC "); printMemAddress address; stream " <= "; stream(Address.stringOfWord source) ) | ArithByteMemConst { opc, address, source } => ( stream (arithOpRepr opc); stream "MC8"; stream " "; printMemAddress address; stream " "; stream(Word8.toString source) ) | ShiftConstant { shiftType, output, shift, opSize } => ( stream(shiftTypeRepr shiftType); stream(printOpSize opSize); stream " "; printGReg output; stream " by "; stream(Word8.toString shift) ) | ShiftVariable { shiftType, output, opSize } => (* Shift amount is in ecx *) ( stream(shiftTypeRepr shiftType); stream(printOpSize opSize); stream " "; printGReg output; stream " by ECX" ) | ConditionalBranch { test, label=Label{labelNo, ...} } => ( stream "Jump"; stream(branchOpRepr test); stream " L"; stream(Int.toString labelNo) ) | SetCondition { output, test } => ( stream "SetCC"; stream(branchOpRepr test); stream " => "; printGReg output ) | PushToStack source => (stream "Push "; printRegOrMemoryArg printGReg source) | PopR dest => (stream "PopR "; printGReg dest) | LoadAddress{ output, offset, base, index, opSize } => ( stream "LoadAddress"; stream(printOpSize opSize); stream " "; case base of NONE => () | SOME r => (printGReg r; stream " + "); stream(Int.toString offset); case index of NoIndex => () | Index1 x => (stream " + "; printGReg x) | Index2 x => (stream " + "; printGReg x; stream "*2 ") | Index4 x => (stream " + "; printGReg x; stream "*4 ") | Index8 x => (stream " + "; printGReg x; stream "*8 "); stream " => "; printGReg output ) | TestByteBits { arg, bits } => ( stream "TestByteBits "; printRegOrMemoryArg printGReg arg; stream " 0x"; stream(Word8.toString bits) ) | CallRTS {rtsEntry, ...} => ( stream "CallRTS "; case rtsEntry of StackOverflowCall => stream "StackOverflowCall" | HeapOverflowCall => stream "HeapOverflow" | StackOverflowCallEx => stream "StackOverflowCallEx" ) | AllocStore { size, output, ... } => (stream "AllocStore "; stream(Int.toString size); stream " => "; printGReg output ) | AllocStoreVariable { output, size, ...} => (stream "AllocStoreVariable "; printGReg size; stream " => "; printGReg output ) | StoreInitialised => stream "StoreInitialised" | CallAddress source => (stream "CallAddress "; printRegOrMemoryArg printGReg source) | JumpAddress source => (stream "JumpAddress "; printRegOrMemoryArg printGReg source) | ReturnFromFunction argsToRemove => (stream "ReturnFromFunction "; stream(Int.toString argsToRemove)) | RaiseException { workReg } => (stream "RaiseException "; printGReg workReg) | UncondBranch(Label{labelNo, ...})=> (stream "UncondBranch L"; stream(Int.toString labelNo)) | ResetStack{numWords, preserveCC} => (stream "ResetStack "; stream(Int.toString numWords); if preserveCC then stream " preserve CC" else ()) | JumpLabel(Label{labelNo, ...}) => (stream "L"; stream(Int.toString labelNo); stream ":") | LoadLabelAddress{ label=Label{labelNo, ...}, output } => (stream "LoadLabelAddress L"; stream(Int.toString labelNo); stream "=>"; printGReg output) | RepeatOperation repOp => (stream "Repeat "; stream(repOpsRepr repOp)) | DivideAccR{arg, isSigned, opSize} => ( stream(if isSigned then "DivideSigned" else "DivideUnsigned"); stream(printOpSize opSize); stream " "; printGReg arg) | DivideAccM{base, offset, isSigned, opSize} => ( stream(if isSigned then "DivideSigned" else "DivideUnsigned"); stream(printOpSize opSize); stream " "; printBaseOffset(base, NoIndex, offset)) | AtomicXAdd{address, output, opSize} => (stream "LockedXAdd"; stream(printOpSize opSize); printMemAddress address; stream " <=> "; printGReg output) | FPLoadFromMemory{address, precision=DoublePrecision} => (stream "FPLoadDouble "; printMemAddress address) | FPLoadFromMemory{address, precision=SinglePrecision} => (stream "FPLoadSingle "; printMemAddress address) | FPLoadFromFPReg {source, lastRef} => (stream "FPLoad "; printFPReg source; if lastRef then stream " (LAST)" else()) | FPLoadFromConst{constant, precision} => ( case precision of DoublePrecision => stream "FPLoadD " | SinglePrecision => stream "FPLoadS"; stream(Address.stringOfWord constant) ) | FPStoreToFPReg{ output, andPop } => (if andPop then stream "FPStoreAndPop => " else stream "FPStore => "; printFPReg output) | FPStoreToMemory{ address, precision=DoublePrecision, andPop: bool } => ( if andPop then stream "FPStoreDoubleAndPop => " else stream "FPStoreDouble => "; printMemAddress address ) | FPStoreToMemory{ address, precision=SinglePrecision, andPop: bool } => ( if andPop then stream "FPStoreSingleAndPop => " else stream "FPStoreSingle => "; printMemAddress address ) | FPArithR{ opc, source } => (stream(fpOpRepr opc); stream " "; printFPReg source) | FPArithConst{ opc, source, precision } => (stream(fpOpRepr opc); case precision of DoublePrecision => stream "D " | SinglePrecision => stream "S "; stream(Address.stringOfWord source)) | FPArithMemory{ opc, base, offset, precision } => (stream(fpOpRepr opc); case precision of DoublePrecision => stream "D " | SinglePrecision => stream "S "; printBaseOffset(base, NoIndex, offset)) | FPUnary opc => stream(fpUnaryRepr opc) | FPStatusToEAX => (stream "FPStatus "; printGReg eax) | FPLoadInt { base, offset, opSize} => (stream "FPLoadInt"; stream(printOpSize opSize); stream " "; printBaseOffset(base, NoIndex, offset)) | FPFree reg => (stream "FPFree "; printFPReg reg) | MultiplyR {source, output, opSize } => (stream "MultiplyR"; stream(printOpSize opSize); stream " "; printRegOrMemoryArg printGReg source; stream " *=>"; printGReg output) | XMMArith { opc, source, output } => ( stream (sse2OpRepr opc ^ "RM "); printXMMReg output; stream " <= "; printRegOrMemoryArg printXMMReg source ) | XMMStoreToMemory { toStore, address, precision=DoublePrecision } => ( stream "MoveDouble "; printXMMReg toStore; stream " => "; printMemAddress address ) | XMMStoreToMemory { toStore, address, precision=SinglePrecision } => ( stream "MoveSingle "; printXMMReg toStore; stream " => "; printMemAddress address ) | XMMConvertFromInt { source, output, opSize } => ( stream "ConvertFromInt "; stream(printOpSize opSize); stream " "; printGReg source; stream " => "; printXMMReg output ) | SignExtendForDivide opSize => ( stream "SignExtendForDivide"; stream(printOpSize opSize) ) | XChng { reg, arg, opSize } => (stream "XChng"; stream(printOpSize opSize); stream " "; printGReg reg; stream " <=> "; printRegOrMemoryArg printGReg arg) | Negative { output, opSize } => (stream "Negative"; stream(printOpSize opSize); stream " "; printGReg output) | JumpTable{cases, ...} => List.app(fn(Label{labelNo, ...}) => (stream "UncondBranch L"; stream(Int.toString labelNo); stream "\n")) cases | IndexedJumpCalc { addrReg, indexReg, jumpSize=ref jumpSize } => ( stream "IndexedJumpCalc "; printGReg addrReg; stream " += "; printGReg indexReg; stream (case jumpSize of JumpSize2 => " * 2" | JumpSize8 => " * 8 ") ) | MoveXMMRegToGenReg { source, output } => ( stream "MoveXMMRegToGenReg "; printXMMReg source; stream " => "; printGReg output ) | MoveGenRegToXMMReg { source, output } => ( stream "MoveGenRegToXMMReg "; printGReg source; stream " => "; printXMMReg output ) | XMMShiftRight { output, shift } => ( stream "XMMShiftRight "; printXMMReg output; stream " by "; stream(Word8.toString shift) ) | FPLoadCtrlWord address => ( stream "FPLoadCtrlWord "; stream " => "; printMemAddress address ) | FPStoreCtrlWord address => ( stream "FPStoreCtrlWord "; stream " <= "; printMemAddress address ) | XMMLoadCSR address => ( stream "XMMLoadCSR "; stream " => "; printMemAddress address ) | XMMStoreCSR address => ( stream "XMMStoreCSR "; stream " <= "; printMemAddress address ) | FPStoreInt address => ( stream "FPStoreInt "; stream " <= "; printMemAddress address ) | XMMStoreInt{ source, output, precision, isTruncate } => ( stream "XMMStoreInt"; case precision of SinglePrecision => stream "Single" | DoublePrecision => stream "Double"; if isTruncate then stream "Truncate " else stream " "; printGReg output; stream " <= "; printRegOrMemoryArg printXMMReg source ) | CondMove { test, output, source, opSize } => ( stream "CondMove"; stream(branchOpRepr test); stream(printOpSize opSize); printGReg output; stream " <= "; printRegOrMemoryArg printGReg source ) | LoadAbsolute { destination, value } => ( stream "LoadAbsolute "; printGReg destination; stream " <= "; stream(Address.stringOfWord value) ) ; stream "\n" end datatype implement = ImplementGeneral | ImplementLiteral of machineWord fun printLowLevelCode(ops, Code{printAssemblyCode, printStream, procName, ...}) = if printAssemblyCode then ( if procName = "" (* No name *) then printStream "?" else printStream procName; printStream ":\n"; List.app(fn i => printOperation(i, printStream)) ops; printStream "\n" ) else () (* val opLen = if isX64 then OpSize64 else OpSize32 *) (* Code generate a list of operations. The list is in reverse order i.e. last instruction first. *) fun codeGenerate ops = let fun cgOp(Move{source=RegisterArg source, destination=RegisterArg output, moveSize=Move64 }) = (* Move from one general register to another. N.B. Because we're using the "store" version of the Move the source and output are reversed. *) opReg(MOVL_R_A64, source, output) | cgOp(Move{source=RegisterArg source, destination=RegisterArg output, moveSize=Move32 }) = opReg(MOVL_R_A32, source, output) | cgOp(Move{ source=NonAddressConstArg source, destination=RegisterArg output, moveSize=Move64}) = if targetArch <> Native32Bit then ( (* N.B. There is related code in getConstant that deals with PC-relative values and also checks the range of constants that need to be in the constant area. *) if source >= 0 andalso source < 0x100000000 then (* Unsigned 32 bits. We can use a 32-bit instruction to set the value because it will zero extend to 64-bits. This may also allow us to save a rex byte. *) let val (rc, rx) = getReg output val opb = opCodeBytes(MOVL_32_R rc, if rx then SOME{w=false, r=false, b=rx, x=false} else NONE) in opb @ word32Unsigned(LargeWord.fromLargeInt source) end else if source >= ~0x80000000 andalso source < 0 then (* Signed 32-bits. *) (* This is not scanned in 64-bit mode because 32-bit values aren't big enough to contain addresses. *) opRegPlus2(MOVL_32_A64, output, 0w0) @ int32Signed source else (* Too big for 32-bits; put it in the non-word area. *) opConstantOperand(MOVL_A_R64, output) ) else (* 32-bit mode. *) ( (* The RTS scans for possible addresses in MOV instructions so we can only use MOV if this is a tagged value. If it isn't we have to use something else such as XOR/ADD. In particular this is used before LOCK XADD for atomic inc/dec. We expect Move to preserve the CC so shouldn't use anything that affects it. There was a previous comment that said that using LEA wasn't a good idea. Perhaps because it takes 6 bytes. *) if source mod 2 = 0 then opIndexed(LEAL32, source, NONE, NoIndex, output) else let val (rc, rx) = getReg output val opb = opCodeBytes(MOVL_32_R rc, if rx then SOME{w=false, r=false, b=rx, x=false} else NONE) in opb @ int32Signed source end ) | cgOp(Move{ source=NonAddressConstArg source, destination=RegisterArg output, moveSize=Move32}) = if targetArch <> Native32Bit then ( (* N.B. There is related code in getConstant that deals with PC-relative values and also checks the range of constants that need to be in the constant area. *) if source >= 0 andalso source < 0x100000000 then (* Unsigned 32 bits. We can use a 32-bit instruction to set the value because it will zero extend to 64-bits. This may also allow us to save a rex byte. *) let val (rc, rx) = getReg output val opb = opCodeBytes(MOVL_32_R rc, if rx then SOME{w=false, r=false, b=rx, x=false} else NONE) in opb @ word32Unsigned(LargeWord.fromLargeInt source) end else if source >= ~0x80000000 andalso source < 0 then (* Signed 32-bits. *) (* This is not scanned in 64-bit mode because 32-bit values aren't big enough to contain addresses. *) opRegPlus2(MOVL_32_A64, output, 0w0) @ int32Signed source else (* Too big for 32-bits; put it in the non-word area. *) opConstantOperand(MOVL_A_R64, output) ) else (* 32-bit mode. *) ( (* The RTS scans for possible addresses in MOV instructions so we can only use MOV if this is a tagged value. If it isn't we have to use something else such as XOR/ADD. In particular this is used before LOCK XADD for atomic inc/dec. We expect Move to preserve the CC so shouldn't use anything that affects it. There was a previous comment that said that using LEA wasn't a good idea. Perhaps because it takes 6 bytes. *) if source mod 2 = 0 then opIndexed(LEAL32, source, NONE, NoIndex, output) else let val (rc, rx) = getReg output val opb = opCodeBytes(MOVL_32_R rc, if rx then SOME{w=false, r=false, b=rx, x=false} else NONE) in opb @ int32Signed source end ) | cgOp(Move{ source=AddressConstArg _, destination=RegisterArg output, moveSize=Move64 }) = ( (* The constant area is currently PolyWords. That means we MUST use a 32-bit load in 32-in-64. *) targetArch = Native64Bit orelse raise InternalError "Move64 in 32-bit"; (* Put address constants in the constant area. *) opConstantOperand(MOVL_A_R64, output) ) | cgOp(Move{ source=AddressConstArg _, destination=RegisterArg output, moveSize=Move32 }) = ( case targetArch of Native64Bit => raise InternalError "Move32 - AddressConstArg" | ObjectId32Bit => (* Put address constants in the constant area. *) (* The constant area is currently PolyWords. That means we MUST use a 32-bit load in 32-in-64. *) opConstantOperand(MOVL_A_R32, output) | Native32Bit => (* Immediate constant *) let val (rc, _) = getReg output in opCodeBytes(MOVL_32_R rc, NONE) @ int32Signed(tag 0) end ) | cgOp(LoadAbsolute{ destination, ... }) = ( (* Immediate address constant. This is currently only used the special case of loading the address of PolyX86GetThreadData in a callback when we don't have rbx in 32-in-64. *) case targetArch of Native32Bit => let val (rc, _) = getReg destination in opCodeBytes(MOVL_32_R rc, NONE) @ int32Signed(tag 0) end | Native64Bit => opConstantOperand(MOVL_A_R64, destination) | ObjectId32Bit => let val (rc, rx) = getReg destination in opCodeBytes(MOVL_64_R rc, SOME{w=true, r=false, b=rx, x=false}) @ largeWordToBytes(LargeWord.fromLargeInt(tag 0), 8) end ) | cgOp(Move{source=MemoryArg{base, offset, index}, destination=RegisterArg output, moveSize=Move32 }) = opAddress(MOVL_A_R32, LargeInt.fromInt offset, base, index, output) | cgOp(Move{source=MemoryArg{base, offset, index}, destination=RegisterArg output, moveSize=Move64 }) = opAddress(MOVL_A_R64, LargeInt.fromInt offset, base, index, output) | cgOp(Move{source=MemoryArg{base, offset, index}, destination=RegisterArg output, moveSize=Move8 }) = (* We don't need a REX.W bit here because the top 32-bits of a 64-bit register will always be zeroed. *) opAddress(MOVZB, LargeInt.fromInt offset, base, index, output) | cgOp(Move{source=RegisterArg source, destination=RegisterArg output, moveSize=Move8 }) = let (* Zero extend an 8-bit value in a register to 32/64 bits. *) val (rrC, rrX) = getReg output val (rbC, rbX) = getReg source (* We don't need a REX.W bit here because the top 32-bits of a 64-bit register will always be zeroed but we may need a REX byte if we're using esi or edi. *) val rexByte = if rrC < 0w4 andalso not rrX andalso not rbX then NONE else if hostIsX64 then SOME {w=false, r=rrX, b=rbX, x=false} else raise InternalError "Move8 with esi/edi" in opCodeBytes(MOVZB, rexByte) @ [modrm(Register, rrC, rbC)] end | cgOp(Move{source=MemoryArg{base, offset, index}, destination=RegisterArg output, moveSize=Move8X32 }) = opAddress(MOVSXB32, LargeInt.fromInt offset, base, index, output) | cgOp(Move{source=MemoryArg{base, offset, index}, destination=RegisterArg output, moveSize=Move8X64 }) = (* But we will need a Rex.W here. *) opAddress(MOVSXB64, LargeInt.fromInt offset, base, index, output) | cgOp(Move{moveSize=Move16, source=MemoryArg{base, offset, index}, destination=RegisterArg output }) = (* No need for Rex.W *) opAddress(MOVZW, LargeInt.fromInt offset, base, index, output) | cgOp(Move{moveSize=Move16X32, source=MemoryArg{base, offset, index}, destination=RegisterArg output }) = opAddress(MOVSXW32, LargeInt.fromInt offset, base, index, output) | cgOp(Move{moveSize=Move16X64, source=MemoryArg{base, offset, index}, destination=RegisterArg output }) = (* But we do need Rex.W here *) opAddress(MOVSXW64, LargeInt.fromInt offset, base, index, output) | cgOp(Move{moveSize=Move32X64, source=RegisterArg source, destination=RegisterArg output }) = (* We should have a REX.W bit here. *) opReg(MOVSXD, output, source) | cgOp(Move{moveSize=Move32X64, source=MemoryArg{base, offset, index}, destination=RegisterArg output }) = (* We should have a REX.W bit here. *) opAddress(MOVSXD, LargeInt.fromInt offset, base, index, output) | cgOp(Move{moveSize=Move32X64, ...}) = raise InternalError "cgOp: LoadNonWord Size32Bit" | cgOp(LoadAddress{ offset, base, index, output, opSize }) = (* This provides a mixture of addition and multiplication in a single instruction. *) opIndexed(case opSize of OpSize64 => LEAL64 | OpSize32 => LEAL32, LargeInt.fromInt offset, base, index, output) | cgOp(ArithToGenReg{ opc, output, source=RegisterArg source, opSize }) = arithOpReg (opc, output, source, opSize=OpSize64) | cgOp(ArithToGenReg{ opc, output, source=NonAddressConstArg source, opSize }) = let (* On the X86/32 we use CMP with literal sources to compare with an address and the RTS searches for them in the code. Any non-address constant must be tagged. Most will be but we might want to use this to compare with the contents of a LargeWord value. *) val _ = if hostIsX64 orelse is8BitL source orelse opc <> CMP orelse IntInf.andb(source, 1) = 1 then () else raise InternalError "CMP with constant that looks like an address" in immediateOperand(opc, output, source, opSize) end | cgOp(ArithToGenReg{ opc, output, source=AddressConstArg _, opSize }) = (* This is only used for opc=CMP to compare addresses for equality. *) if hostIsX64 then (* We use this in 32-in-64 as well as native 64-bit. *) opConstantOperand( (case opSize of OpSize64 => Arith64 | OpSize32 => Arith32) (opc, 0w3), output) else let val (rc, _) = getReg output val opb = opCodeBytes(Group1_32_A32 (* group1, 32 bit immediate *), NONE) val mdrm = modrm(Register, arithOpToWord opc, rc) in opb @ [mdrm] @ int32Signed(tag 0) end | cgOp(ArithToGenReg{ opc, output, source=MemoryArg{offset, base, index}, opSize }) = opAddress((case opSize of OpSize64 => Arith64 | OpSize32 => Arith32) (opc, 0w3), LargeInt.fromInt offset, base, index, output) | cgOp(ArithByteMemConst{ opc, address={offset, base, index}, source }) = opIndexedPlus2(Group1_8_a (* group1, 8 bit immediate *), LargeInt.fromInt offset, base, index, arithOpToWord opc) @ [source] | cgOp(ArithMemConst{ opc, address={offset, base, index}, source, opSize }) = if is8BitL source then (* Can use one byte immediate *) opIndexedPlus2(case opSize of OpSize64 => Group1_8_A64 | OpSize32 => Group1_8_A32 (* group1, 8 bit immediate *), LargeInt.fromInt offset, base, index, arithOpToWord opc) @ [Word8.fromLargeInt source] else (* Need 32 bit immediate. *) opIndexedPlus2(case opSize of OpSize64 => Group1_32_A64 | OpSize32 => Group1_32_A32(* group1, 32 bit immediate *), LargeInt.fromInt offset, base, index, arithOpToWord opc) @ int32Signed source | cgOp(ArithMemLongConst{ opc, address={offset, base, index}, ... }) = (* Currently this is always a comparison. It is only valid in 32-bit mode because the constant is only 32-bits. *) if hostIsX64 then raise InternalError "ArithMemLongConst in 64-bit mode" else let val opb = opIndexedPlus2 (Group1_32_A32, LargeInt.fromInt offset, base, index, arithOpToWord opc) in opb @ int32Signed(tag 0) end | cgOp(ShiftConstant { shiftType, output, shift, opSize }) = if shift = 0w1 then opRegPlus2(case opSize of OpSize64 => Group2_1_A64 | OpSize32 => Group2_1_A32, output, shiftTypeToWord shiftType) else opRegPlus2(case opSize of OpSize64 => Group2_8_A64 | OpSize32 => Group2_8_A32, output, shiftTypeToWord shiftType) @ [shift] | cgOp(ShiftVariable { shiftType, output, opSize }) = opRegPlus2(case opSize of OpSize64 => Group2_CL_A64 | OpSize32 => Group2_CL_A32, output, shiftTypeToWord shiftType) | cgOp(TestByteBits{arg=RegisterArg reg, bits}) = let (* Test the bottom bit and jump depending on its value. This is used for tag tests in arbitrary precision operations and also for testing for short/long values. *) val (regNum, rx) = getReg reg in if reg = eax then (* Special instruction for testing accumulator. Can use an 8-bit test. *) opCodeBytes(TEST_ACC8, NONE) @ [bits] else if hostIsX64 then let (* We can use a REX code to force it to always use the low order byte. *) val opb = opCodeBytes(Group3_a, if rx orelse regNum >= 0w4 then SOME{w=false, r=false, b=rx, x=false} else NONE) val mdrm = modrm (Register, 0w0 (* test *), regNum) in opb @ [mdrm, bits] end else if reg = ebx orelse reg = ecx orelse reg = edx (* can we use an 8-bit test? *) then (* Yes. The register value refers to low-order byte. *) let val opb = opCodeBytes(Group3_a, NONE) val mdrm = modrm(Register, 0w0 (* test *), regNum) in opb @ [mdrm, bits] end else let val opb = opCodeBytes(Group3_A32, NONE) val mdrm = modrm (Register, 0w0 (* test *), regNum) in opb @ mdrm :: word32Unsigned(Word8.toLarge bits) end end | cgOp(TestByteBits{arg=MemoryArg{base, offset, index}, bits}) = (* Test the tag bit and set the condition code. *) opIndexedPlus2(Group3_a, LargeInt.fromInt offset, base, index, 0w0 (* test *)) @ [ bits] | cgOp(TestByteBits _) = raise InternalError "cgOp: TestByteBits" | cgOp(ConditionalBranch{ test=opc, ... }) = opCodeBytes(CondJump32 opc, NONE) @ word32Unsigned 0w0 | cgOp(SetCondition{ output, test}) = let val (rrC, rx) = getReg output (* In 64-bit mode we can specify the low-order byte of RSI/RDI but we must use a REX prefix. This isn't possible in 32-bit mode. *) in if hostIsX64 orelse rrC < 0w4 then let val opb = opCodeBytes(SetCC test, if rx orelse rrC >= 0w4 then SOME{w=false, r=false, b=rx, x=false} else NONE) val mdrm = modrm (Register, 0w0, rrC) in opb @ [mdrm] end else raise InternalError "High byte register" end | cgOp(CallRTS{rtsEntry, saveRegs}) = rtsCall(rtsEntry, saveRegs) | cgOp(RepeatOperation repOp) = let (* We don't explicitly clear the direction flag. Should that be done? *) val opb = opCodeBytes(REP, NONE) (* Put in a rex prefix to force 64-bit mode. *) val optRex = if case repOp of STOS64 => true | MOVS64 => true | _ => false then [rex{w=true, r=false, b=false, x=false}] else [] val repOp = repOpsToWord repOp in opb @ optRex @ [repOp] end | cgOp(DivideAccR{arg, isSigned, opSize}) = opRegPlus2(case opSize of OpSize64 => Group3_A64 | OpSize32 => Group3_A32, arg, if isSigned then 0w7 else 0w6) | cgOp(DivideAccM{base, offset, isSigned, opSize}) = opPlus2(case opSize of OpSize64 => Group3_A64 | OpSize32 => Group3_A32, LargeInt.fromInt offset, base, if isSigned then 0w7 else 0w6) | cgOp(AtomicXAdd{address={offset, base, index}, output, opSize}) = (* Locked exchange-and-add. We need the lock prefix before the REX prefix. *) opAddress(case opSize of OpSize64 => LOCK_XADD64 | OpSize32 => LOCK_XADD32, LargeInt.fromInt offset, base, index, output) | cgOp(PushToStack(RegisterArg reg)) = let val (rc, rx) = getReg reg in (* Always 64-bit but a REX prefix may be needed for the register. *) opCodeBytes(PUSH_R rc, if rx then SOME{w=false, b = true, x=false, r = false } else NONE) end | cgOp(PushToStack(MemoryArg{base, offset, index})) = opAddressPlus2(Group5, LargeInt.fromInt offset, base, index, 0w6 (* push *)) | cgOp(PushToStack(NonAddressConstArg constnt)) = if is8BitL constnt then opCodeBytes(PUSH_8, NONE) @ [Word8.fromLargeInt constnt] else if is32bit constnt then opCodeBytes(PUSH_32, NONE) @ int32Signed constnt else (* It won't fit in the immediate; put it in the non-address area. *) let val opb = opCodeBytes(Group5, NONE) val mdrm = modrm(Based0, 0w6 (* push *), 0w5 (* PC rel *)) in opb @ [mdrm] @ int32Signed(tag 0) end | cgOp(PushToStack(AddressConstArg _)) = ( case targetArch of Native64Bit => (* Put it in the constant area. *) let val opb = opCodeBytes(Group5, NONE) val mdrm = modrm(Based0, 0w6 (* push *), 0w5 (* PC rel *)); in opb @ [mdrm] @ int32Signed(tag 0) end | Native32Bit => opCodeBytes(PUSH_32, NONE) @ int32Signed(tag 0) | ObjectId32Bit => (* We can't do this. The constant area contains 32-bit quantities and 32-bit literals are sign-extended rather than zero-extended. *) raise InternalError "PushToStack:AddressConstArg" ) | cgOp(PopR reg ) = let val (rc, rx) = getReg reg in (* Always 64-bit but a REX prefix may be needed for the register. Because the register is encoded in the instruction the rex bit for the register is b not r. *) opCodeBytes(POP_R rc, if rx then SOME{w=false, b = true, x=false, r = false } else NONE) end | cgOp(Move{source=RegisterArg toStore, destination=MemoryArg{offset, base, index}, moveSize=Move64}) = opAddress(MOVL_R_A64, LargeInt.fromInt offset, base, index, toStore) | cgOp(Move{source=RegisterArg toStore, destination=MemoryArg{offset, base, index}, moveSize=Move32}) = opAddress(MOVL_R_A32, LargeInt.fromInt offset, base, index, toStore) | cgOp(Move{source=NonAddressConstArg toStore, destination=MemoryArg{offset, base, index}, moveSize=Move64 }) = ( (* Short constant. In 32-bit mode this is scanned as a possible address. That means we can't have an untagged constant in it. That's not a problem in 64-bit mode. There's a special check for using this to set the length word on newly allocated memory. *) targetArch <> Native32Bit orelse toStore = 0 orelse toStore mod 2 = 1 orelse offset = ~ (Word.toInt wordSize) orelse raise InternalError "cgOp: StoreConstToMemory not tagged"; opAddressPlus2(MOVL_32_A64, LargeInt.fromInt offset, base, index, 0w0) @ int32Signed toStore ) | cgOp(Move{source=NonAddressConstArg toStore, destination=MemoryArg{offset, base, index}, moveSize=Move32 }) = ( (* Short constant. In 32-bit mode this is scanned as a possible address. That means we can't have an untagged constant in it. That's not a problem in 64-bit mode. There's a special check for using this to set the length word on newly allocated memory. *) targetArch <> Native32Bit orelse toStore = 0 orelse toStore mod 2 = 1 orelse offset = ~ (Word.toInt wordSize) orelse raise InternalError "cgOp: StoreConstToMemory not tagged"; opAddressPlus2(MOVL_32_A32, LargeInt.fromInt offset, base, index, 0w0) @ int32Signed toStore ) | cgOp(Move{source=AddressConstArg _, destination=MemoryArg{offset, base, index}, moveSize=Move32}) = (* This is not used for addresses even in 32-in-64. We don't scan for addresses after MOVL_32_A. *) if targetArch <> Native32Bit then raise InternalError "StoreLongConstToMemory in 64-bit mode" else opAddressPlus2(MOVL_32_A32, LargeInt.fromInt offset, base, index, 0w0) @ int32Signed (tag 0) | cgOp(Move{source=AddressConstArg _, destination=MemoryArg _, ...}) = raise InternalError "cgOp: Move - AddressConstArg => MemoryArg" | cgOp(Move{ moveSize = Move8, source=RegisterArg toStore, destination=MemoryArg{offset, base, index} }) = let val (rrC, _) = getReg toStore (* In 64-bit mode we can specify the low-order byte of RSI/RDI but we must use a REX prefix. This isn't possible in 32-bit mode. *) val opcode = if hostIsX64 then MOVB_R_A64{forceRex= rrC >= 0w4} else if rrC < 0w4 then MOVB_R_A32 else raise InternalError "High byte register" in opAddress(opcode, LargeInt.fromInt offset, base, index, toStore) end | cgOp(Move{ moveSize = Move16, source=RegisterArg toStore, destination=MemoryArg{offset, base, index}}) = opAddress(MOVL_R_A16, LargeInt.fromInt offset, base, index, toStore) | cgOp(Move{ moveSize = Move8, source=NonAddressConstArg toStore, destination=MemoryArg{offset, base, index}}) = opAddressPlus2(MOVB_8_A, LargeInt.fromInt offset, base, index, 0w0) @ [Word8.fromLargeInt toStore] | cgOp(Move _) = raise InternalError "Move: Unimplemented arguments" (* Allocation is dealt with by expanding the code. *) | cgOp(AllocStore _) = raise InternalError "cgOp: AllocStore" | cgOp(AllocStoreVariable _) = raise InternalError "cgOp: AllocStoreVariable" | cgOp StoreInitialised = raise InternalError "cgOp: StoreInitialised" | cgOp(CallAddress(NonAddressConstArg _)) = (* Call to the start of the code. Offset is patched in later. *) opCodeBytes (CALL_32, NONE) @ int32Signed 0 | cgOp(CallAddress(AddressConstArg _)) = if targetArch = Native64Bit then let val opc = opCodeBytes(Group5, NONE) val mdrm = modrm(Based0, 0w2 (* call *), 0w5 (* PC rel *)) in opc @ [mdrm] @ int32Signed(tag 0) end (* Because this is a relative branch we need to point this at itself. Until it is set to the relative offset of the destination it needs to contain an address within the code and this could be the last instruction. *) else opCodeBytes (CALL_32, NONE) @ int32Signed ~5 | cgOp(CallAddress(RegisterArg reg)) = opRegPlus2(Group5, reg, 0w2 (* call *)) | cgOp(CallAddress(MemoryArg{base, offset, index})) = opAddressPlus2(Group5, LargeInt.fromInt offset, base, index, 0w2 (* call *)) | cgOp(JumpAddress(NonAddressConstArg _)) = (* Jump to the start of the current function. Offset is patched in later. *) opCodeBytes (JMP_32, NONE) @ int32Signed 0 | cgOp(JumpAddress (AddressConstArg _)) = if targetArch = Native64Bit then let val opb = opCodeBytes (Group5, NONE) val mdrm = modrm(Based0, 0w4 (* jmp *), 0w5 (* PC rel *)) in opb @ [mdrm] @ int32Signed(tag 0) end else opCodeBytes (JMP_32, NONE) @ int32Signed ~5 (* As with Call. *) | cgOp(JumpAddress (RegisterArg reg)) = (* Used as part of indexed case - not for entering a function. *) opRegPlus2(Group5, reg, 0w4 (* jmp *)) | cgOp(JumpAddress(MemoryArg{base, offset, index})) = opAddressPlus2(Group5, LargeInt.fromInt offset, base, index, 0w4 (* jmp *)) | cgOp(ReturnFromFunction args) = if args = 0 then opCodeBytes(RET, NONE) else let val offset = Word.fromInt args * nativeWordSize in opCodeBytes(RET_16, NONE) @ [wordToWord8 offset, wordToWord8(offset >> 0w8)] end | cgOp (RaiseException { workReg }) = opEA(if hostIsX64 then MOVL_A_R64 else MOVL_A_R32, LargeInt.fromInt memRegHandlerRegister, ebp, workReg) @ opAddressPlus2(Group5, 0, workReg, NoIndex, 0w4 (* jmp *)) | cgOp(UncondBranch _) = opToInt JMP_32 :: word32Unsigned 0w0 | cgOp(ResetStack{numWords, preserveCC}) = let val bytes = Word.toLargeInt(Word.fromInt numWords * nativeWordSize) in (* If we don't need to preserve the CC across the reset we use ADD since it's shorter. *) if preserveCC then opEA(if hostIsX64 then LEAL64 else LEAL32, bytes, esp, esp) else immediateOperand(ADD, esp, bytes, if hostIsX64 then OpSize64 else OpSize32) end | cgOp(JumpLabel _) = [] (* No code. *) | cgOp(LoadLabelAddress{ output, ... }) = (* Load the address of a label. Used when setting up an exception handler or in indexed cases. *) (* On X86/64 we can use pc-relative addressing to set the start of the handler. On X86/32 we have to load the address of the start of the code and add an offset. *) if hostIsX64 then opConstantOperand(LEAL64, output) else let val (rc, _) = getReg output in opCodeBytes(MOVL_32_R rc , NONE) @ int32Signed(tag 0) @ opRegPlus2(Group1_32_A32, output, arithOpToWord ADD) @ int32Signed 0 end | cgOp (FPLoadFromMemory {address={ base, offset, index }, precision}) = let val loadInstr = case precision of DoublePrecision => FPESC 0w5 | SinglePrecision => FPESC 0w1 in opAddressPlus2(loadInstr, LargeInt.fromInt offset, base, index, 0wx0) end | cgOp (FPLoadFromFPReg{source=FloatingPtReg fp, ...}) = (* Assume there's nothing currently on the stack. *) floatingPtOp({escape=0w1, md=0w3, nnn=0w0, rm= fp + 0w0}) (* FLD ST(r1) *) | cgOp (FPLoadFromConst {precision, ...} ) = (* The real constant here is actually the address of a memory object. FLD takes the address as the argument and in 32-bit mode we use an absolute address. In 64-bit mode we need to put the constant at the end of the code segment and use PC-relative addressing which happens to be encoded in the same way. There are special cases for zero and one but it's probably too much work to detect them. *) let val esc = case precision of SinglePrecision => 0w1 | DoublePrecision => 0w5 val opb = opCodeBytes(FPESC esc, NONE) (* FLD [Constant] *) val mdrm = modrm (Based0, 0w0, 0w5 (* constant address/PC-relative *)) in opb @ [mdrm] @ int32Signed(tag 0) end | cgOp (FPStoreToFPReg{ output=FloatingPtReg dest, andPop }) = (* Assume there's one item on the stack. *) floatingPtOp({escape=0w5, md=0w3, nnn=if andPop then 0wx3 else 0wx2, rm = dest+0w1(* One item *)}) (* FSTP ST(n+1) *) | cgOp (FPStoreToMemory{address={ base, offset, index}, precision, andPop }) = let val storeInstr = case precision of DoublePrecision => FPESC 0w5 | SinglePrecision => FPESC 0w1 val subInstr = if andPop then 0wx3 else 0wx2 in opAddressPlus2(storeInstr, LargeInt.fromInt offset, base, index, subInstr) end | cgOp (FPArithR{ opc, source = FloatingPtReg src}) = floatingPtOp({escape=0w0, md=0w3, nnn=fpOpToWord opc, rm=src + 0w1 (* One item already there *)}) | cgOp (FPArithConst{ opc, precision, ... }) = (* See comment on FPLoadFromConst *) let val fpesc = case precision of DoublePrecision => 0w4 | SinglePrecision => 0w0 val opb = opCodeBytes(FPESC fpesc, NONE) (* FADD etc [constnt] *) val mdrm = modrm (Based0, fpOpToWord opc, 0w5 (* constant address *)) in opb @ [mdrm] @ int32Signed(tag 0) end | cgOp (FPArithMemory{ opc, base, offset, precision }) = let val fpesc = case precision of DoublePrecision => 0w4 | SinglePrecision => 0w0 in opPlus2(FPESC fpesc, LargeInt.fromInt offset, base, fpOpToWord opc) (* FADD/FMUL etc [r2] *) end | cgOp (FPUnary opc ) = let val {rm, nnn} = fpUnaryToWords opc in floatingPtOp({escape=0w1, md=0w3, nnn=nnn, rm=rm}) (* FCHS etc *) end | cgOp (FPStatusToEAX ) = opCodeBytes(FPESC 0w7, NONE) @ [0wxe0] (* FNSTSW AX *) | cgOp (FPFree(FloatingPtReg reg)) = floatingPtOp({escape=0w5, md=0w3, nnn=0w0, rm=reg}) (* FFREE FP(n) *) | cgOp (FPLoadInt{base, offset, opSize=OpSize64}) = (* fildl (esp) in 32-bit mode or fildq (esp) in 64-bit mode. *) opPlus2(FPESC 0w7, LargeInt.fromInt offset, base, 0w5) | cgOp (FPLoadInt{base, offset, opSize=OpSize32}) = (* fildl (esp) in 32-bit mode or fildq (esp) in 64-bit mode. *) opPlus2(FPESC 0w3, LargeInt.fromInt offset, base, 0w0) | cgOp (MultiplyR {source=RegisterArg srcReg, output, opSize}) = (* We use the 0F AF form of IMUL rather than the Group3 MUL or IMUL because the former allows us to specify the destination register. The Group3 forms produce double length results in RAX:RDX/EAX:EDX but we only ever want the low-order half. *) opReg(case opSize of OpSize64 => IMUL64 | OpSize32 => IMUL32 (* 2 byte opcode *), output, srcReg) | cgOp (MultiplyR {source=MemoryArg{base, offset, index}, output, opSize}) = (* This may be used for large-word multiplication. *) opAddress(case opSize of OpSize64 => IMUL64 | OpSize32 => IMUL32 (* 2 byte opcode *), LargeInt.fromInt offset, base, index, output) | cgOp(MultiplyR {source=NonAddressConstArg constnt, output, opSize}) = (* If the constant is an 8-bit or 32-bit value we are actually using a three-operand instruction where the argument can be a register or memory and the destination register does not need to be the same as the source. *) if is8BitL constnt then opReg(case opSize of OpSize64 => IMUL_C8_64 | OpSize32 => IMUL_C8_32, output, output) @ [Word8.fromLargeInt constnt] else if is32bit constnt then opReg(case opSize of OpSize64 => IMUL_C32_64 | OpSize32 => IMUL_C32_32, output, output) @ int32Signed constnt else opConstantOperand(case opSize of OpSize64 => IMUL64 | OpSize32 => IMUL32, output) | cgOp(MultiplyR {source=AddressConstArg _, ...}) = raise InternalError "Multiply - address constant" | cgOp (XMMArith { opc, source=MemoryArg{base, offset, index}, output }) = mMXAddress(SSE2Ops opc, LargeInt.fromInt offset, base, index, output) | cgOp (XMMArith { opc, source=AddressConstArg _, output=SSE2Reg rrC }) = let (* The real constant here is actually the address of an 8-byte memory object. In 32-bit mode we put this address into the code and retain this memory object. In 64-bit mode we copy the real value out of the memory object into the non-address constant area and use PC-relative addressing. These happen to be encoded the same way. *) val opb = opCodeBytes(SSE2Ops opc, NONE) val mdrm = modrm (Based0, rrC, 0w5 (* constant address/PC-relative *)) in opb @ [mdrm] @ int32Signed(tag 0) end | cgOp (XMMArith { opc, source=RegisterArg(SSE2Reg rrS), output=SSE2Reg rrC }) = let val oper = SSE2Ops opc val pref = opcodePrefix oper val esc = escapePrefix oper val opc = opToInt oper val mdrm = modrm(Register, rrC, rrS) in pref @ esc @ [opc, mdrm] end | cgOp (XMMArith { opc, source=NonAddressConstArg _, output=SSE2Reg rrC }) = let val _ = hostIsX64 orelse raise InternalError "XMMArith-NonAddressConstArg in 32-bit mode" (* This is currently used for 32-bit float arguments but can equally be used for 64-bit values since the actual argument will always be put in the 64-bit constant area. *) val opb = opCodeBytes(SSE2Ops opc, NONE) val mdrm = modrm (Based0, rrC, 0w5 (* constant address/PC-relative *)) in opb @ [mdrm] @ int32Signed(tag 0) end | cgOp (XMMStoreToMemory { toStore, address={base, offset, index}, precision }) = let val oper = case precision of DoublePrecision => SSE2StoreDouble | SinglePrecision => SSE2StoreSingle in mMXAddress(oper, LargeInt.fromInt offset, base, index, toStore) end | cgOp (XMMConvertFromInt { source, output=SSE2Reg rrC, opSize }) = let (* The source is a general register and the output a XMM register. *) (* TODO: The source can be a memory location. *) val (rbC, rbX) = getReg source val oper = case opSize of OpSize64 => CVTSI2SD64 | OpSize32 => CVTSI2SD32 in (* This is a special case with both an XMM and general register. *) opcodePrefix oper @ rexByte(oper, false, rbX, false) @ escapePrefix oper @ [opToInt oper, modrm(Register, rrC, rbC)] end | cgOp (SignExtendForDivide OpSize64) = opCodeBytes(CQO_CDQ64, SOME {w=true, r=false, b=false, x=false}) | cgOp (SignExtendForDivide OpSize32) = opCodeBytes(CQO_CDQ32, NONE) | cgOp (XChng { reg, arg=RegisterArg regY, opSize }) = opReg(case opSize of OpSize64 => XCHNG64 | OpSize32 => XCHNG32, reg, regY) | cgOp (XChng { reg, arg=MemoryArg{offset, base, index}, opSize }) = opAddress(case opSize of OpSize64 => XCHNG64 | OpSize32 => XCHNG32, LargeInt.fromInt offset, base, index, reg) | cgOp (XChng _) = raise InternalError "cgOp: XChng" | cgOp (Negative {output, opSize}) = opRegPlus2(case opSize of OpSize64 => Group3_A64 | OpSize32 => Group3_A32, output, 0w3 (* neg *)) | cgOp (JumpTable{cases, jumpSize=ref jumpSize}) = let val _ = jumpSize = JumpSize8 orelse raise InternalError "cgOp: JumpTable" (* Make one jump for each case and pad it 8 bytes with Nops. *) fun makeJump (_, l) = opToInt JMP_32 :: word32Unsigned 0w0 @ [opToInt NOP, opToInt NOP, opToInt NOP] @ l in List.foldl makeJump [] cases end | cgOp(IndexedJumpCalc{ addrReg, indexReg, jumpSize=ref jumpSize }) = ( jumpSize = JumpSize8 orelse raise InternalError "cgOp: IndexedJumpCalc"; (* Should currently be JumpSize8 which requires a multiplier of 4 and 4 to be subtracted to remove the shifted tag. *) opAddress(if hostIsX64 then LEAL64 else LEAL32, ~4, addrReg, Index4 indexReg, addrReg) ) | cgOp(MoveXMMRegToGenReg { source=SSE2Reg rrC, output }) = let (* The source is a XMM register and the output a general register. *) val (rbC, rbX) = getReg output val oper = MOVDFromXMM in (* This is a special case with both an XMM and general register. *) opcodePrefix oper @ rexByte(oper, false, rbX, false) @ escapePrefix oper @ [opToInt oper, modrm(Register, rrC, rbC)] end | cgOp(MoveGenRegToXMMReg { source, output=SSE2Reg rrC }) = let (* The source is a general register and the output a XMM register. *) val (rbC, rbX) = getReg source val oper = MOVQToXMM in (* This is a special case with both an XMM and general register. *) (* This needs to move the whole 64-bit value. TODO: This is inconsistent with MoveXMMRegToGenReg *) opcodePrefix oper @ rexByte(oper, false, rbX, false) @ escapePrefix oper @ [opToInt oper, modrm(Register, rrC, rbC)] end | cgOp(XMMShiftRight { output=SSE2Reg rrC, shift }) = let val oper = PSRLDQ in opcodePrefix oper @ escapePrefix oper @ [opToInt oper, modrm(Register, 0w3, rrC), shift] end | cgOp(FPLoadCtrlWord {base, offset, index}) = opIndexedPlus2(FPESC 0w1, LargeInt.fromInt offset, base, index, 0w5) | cgOp(FPStoreCtrlWord {base, offset, index}) = opIndexedPlus2(FPESC 0w1, LargeInt.fromInt offset, base, index, 0w7) | cgOp(XMMLoadCSR {base, offset, index}) = opIndexedPlus2(LDSTMXCSR, LargeInt.fromInt offset, base, index, 0w2) | cgOp(XMMStoreCSR {base, offset, index}) = opIndexedPlus2(LDSTMXCSR, LargeInt.fromInt offset, base, index, 0w3) | cgOp(FPStoreInt {base, offset, index}) = (* fistp dword ptr [esp] in 32-bit mode or fistp qword ptr [rsp] in 64-bit mode. *) if hostIsX64 then opIndexedPlus2(FPESC 0w7, LargeInt.fromInt offset, base, index, 0w7) else opIndexedPlus2(FPESC 0w3, LargeInt.fromInt offset, base, index, 0w3) | cgOp(XMMStoreInt {source, output, precision, isTruncate}) = let (* The destination is a general register. The source is an XMM register or memory. *) val (rbC, rbX) = getReg output val oper = case (hostIsX64, precision, isTruncate) of (false, DoublePrecision, false) => CVTSD2SI32 | (true, DoublePrecision, false) => CVTSD2SI64 | (false, SinglePrecision, false) => CVTSS2SI32 | (true, SinglePrecision, false) => CVTSS2SI64 | (false, DoublePrecision, true) => CVTTSD2SI32 | (true, DoublePrecision, true) => CVTTSD2SI64 | (false, SinglePrecision, true) => CVTTSS2SI32 | (true, SinglePrecision, true) => CVTTSS2SI64 in case source of MemoryArg{base, offset, index} => opAddress(oper, LargeInt.fromInt offset, base, index, output) | RegisterArg(SSE2Reg rrS) => opcodePrefix oper @ rexByte(oper, rbX, false, false) @ escapePrefix oper @ [opToInt oper, modrm(Register, rbC, rrS)] | _ => raise InternalError "XMMStoreInt: Not register or memory" end | cgOp(CondMove { test, output, source=RegisterArg source, opSize=OpSize32 }) = opReg(CMOV32 test, output, source) | cgOp(CondMove { test, output, source=RegisterArg source, opSize=OpSize64 }) = opReg(CMOV64 test, output, source) | cgOp(CondMove { test, output, source=NonAddressConstArg _, opSize }) = ( (* We currently support only native-64 bit and put the constant in the non-address constant area. These are 64-bit values both in native 64-bit and in 32-in-64. To support it in 32-bit mode we'd have to put the constant in a single-word object and put its absolute address into the code. *) targetArch <> Native32Bit orelse raise InternalError "CondMove: constant in 32-bit mode"; opConstantOperand((case opSize of OpSize32 => CMOV32 | OpSize64 => CMOV64) test, output) ) | cgOp(CondMove { test, output, source=AddressConstArg _, opSize=OpSize64 }) = (* An address constant. The opSize must match the size of a polyWord since the value it going into the constant area. *) ( targetArch = Native64Bit orelse raise InternalError "CondMove: AddressConstArg"; opConstantOperand(CMOV64 test, output) ) | cgOp(CondMove { test, output, source=AddressConstArg _, opSize=OpSize32 }) = ( (* We only support address constants in 32-in-64. *) targetArch = ObjectId32Bit orelse raise InternalError "CondMove: AddressConstArg"; opConstantOperand(CMOV32 test, output) ) | cgOp(CondMove { test, output, source=MemoryArg{base, offset, index}, opSize=OpSize32 }) = opAddress(CMOV32 test, LargeInt.fromInt offset, base, index, output) | cgOp(CondMove { test, output, source=MemoryArg{base, offset, index}, opSize=OpSize64 }) = opAddress(CMOV64 test, LargeInt.fromInt offset, base, index, output) in List.rev(List.foldl (fn (c, list) => Word8Vector.fromList(cgOp c) :: list) [] ops) end (* General function to process the code. ic is the byte counter within the original code. *) fun foldCode foldFn n (ops, byteList) = let fun doFold(oper :: operList, bytes :: byteList, ic, acc) = doFold(operList, byteList, ic + Word.fromInt(Word8Vector.length bytes), foldFn(oper, bytes, ic, acc)) | doFold(_, _, _, n) = n in doFold(ops, byteList, 0w0, n) end (* Go through the code and update branch and similar instructions with the destinations of the branches. Long branches are converted to short where possible and the code is reprocessed. That might repeat if the effect of shorting one branch allows another to be shortened. *) fun fixupLabels(ops, bytesList, labelCount) = let (* Label array - initialise to 0wxff... . Every label should be defined but just in case, this is more likely to be detected in int32Signed. *) val labelArray = Array.array(labelCount, ~ 0w1) (* First pass - Set the addresses of labels. *) fun setLabelAddresses(oper :: operList, bytes :: byteList, ic) = ( case oper of JumpLabel(Label{labelNo, ...}) => Array.update(labelArray, labelNo, ic) | _ => (); setLabelAddresses(operList, byteList, ic + Word.fromInt(Word8Vector.length bytes)) ) | setLabelAddresses(_, _, ic) = ic (* Return the length of the code. *) fun fixup32(destination, bytes, ic) = let val brLength = Word8Vector.length bytes (* The offset is relative to the end of the branch instruction. *) val diff = Word.toInt destination - Word.toInt ic - brLength in Word8VectorSlice.concat[ Word8VectorSlice.slice(bytes, 0, SOME(brLength-4)), (* The original opcode. *) Word8VectorSlice.full(Word8Vector.fromList(int32Signed(LargeInt.fromInt diff))) ] end fun fixupAddress(UncondBranch(Label{labelNo, ...}), bytes, ic, list) = let val destination = Array.sub(labelArray, labelNo) val brLength = Word8Vector.length bytes (* The offset is relative to the end of the branch instruction. *) val diff = Word.toInt destination - Word.toInt ic - brLength in if brLength = 2 then (* It's a short branch. Take the original operand and set the relative offset. *) Word8Vector.fromList [opToInt JMP_8, byteSigned diff] :: list else if brLength <> 5 then raise InternalError "fixupAddress" else (* 32-bit offset. If it will fit in a byte we can use a short branch. If this is a reverse branch we can actually use values up to -131 here because we've calculated using the end of the long branch. *) if diff <= 127 andalso diff >= ~(128 + 3) then Word8Vector.fromList [opToInt JMP_8, 0w0 (* Fixed on next pass *)] :: list else Word8Vector.fromList(opToInt JMP_32 :: int32Signed(LargeInt.fromInt diff)) :: list end | fixupAddress(ConditionalBranch{label=Label{labelNo, ...}, test, ...}, bytes, ic, list) = let val destination = Array.sub(labelArray, labelNo) val brLength = Word8Vector.length bytes (* The offset is relative to the end of the branch instruction. *) val diff = Word.toInt destination - Word.toInt ic - brLength in if brLength = 2 then (* It's a short branch. Take the original operand and set the relative offset. *) Word8Vector.fromList [opToInt(CondJump test), byteSigned diff] :: list else if brLength <> 6 then raise InternalError "fixupAddress" else if diff <= 127 andalso diff >= ~(128+4) then Word8Vector.fromList[opToInt(CondJump test), 0w0 (* Fixed on next pass *)] :: list else Word8Vector.fromList(opCodeBytes(CondJump32 test, NONE) @ int32Signed(LargeInt.fromInt diff)) :: list end | fixupAddress(LoadLabelAddress{ label=Label{labelNo, ...}, ... }, brCode, ic, list) = let val destination = Array.sub(labelArray, labelNo) in if hostIsX64 then (* This is a relative offset on the X86/64. *) fixup32(destination, brCode, ic) :: list else (* On X86/32 the address is relative to the start of the code so we simply put in the destination address. *) Word8VectorSlice.concat[ Word8VectorSlice.slice(brCode, 0, SOME(Word8Vector.length brCode-4)), Word8VectorSlice.full(Word8Vector.fromList(int32Signed(Word.toLargeInt destination)))] :: list end | fixupAddress(JumpTable{cases, jumpSize as ref JumpSize8}, brCode: Word8Vector.vector, ic, list) = let (* Each branch is a 32-bit jump padded up to 8 bytes. *) fun processCase(Label{labelNo, ...} :: cases, offset, ic) = fixup32(Array.sub(labelArray, labelNo), Word8VectorSlice.vector(Word8VectorSlice.slice(brCode, offset, SOME 5)), ic) :: Word8VectorSlice.vector(Word8VectorSlice.slice(brCode, offset+5, SOME 3)) :: processCase(cases, offset+8, ic+0w8) | processCase _ = [] (* Could we use short branches? If all of the branches were short the table would be smaller so the offsets we use would be less. Ignore backwards branches - could only occur if we have linked labels in a loop. *) val newStartOfCode = ic + Word.fromInt(List.length cases * 6) fun tryShort(Label{labelNo, ...} :: cases, ic) = let val destination = Array.sub(labelArray, labelNo) in if destination > ic + 0w2 andalso destination - ic - 0w2 < 0w127 then tryShort(cases, ic+0w2) else false end | tryShort _ = true val newCases = if tryShort(cases, newStartOfCode) then ( jumpSize := JumpSize2; (* Generate a short branch table. *) List.map(fn _ => Word8Vector.fromList [opToInt JMP_8, 0w0 (* Fixed on next pass *)]) cases ) else processCase(cases, 0, ic) in Word8Vector.concat newCases :: list end | fixupAddress(JumpTable{cases, jumpSize=ref JumpSize2}, _, ic, list) = let (* Each branch is a short jump. *) fun processCase(Label{labelNo, ...} :: cases, offset, ic) = let val destination = Array.sub(labelArray, labelNo) val brLength = 2 val diff = Word.toInt destination - Word.toInt ic - brLength in Word8Vector.fromList[opToInt JMP_8, byteSigned diff] :: processCase(cases, offset+2, ic+0w2) end | processCase _ = [] in Word8Vector.concat(processCase(cases, 0, ic)) :: list end (* If we've shortened a jump table we have to change the indexing. *) | fixupAddress(IndexedJumpCalc{ addrReg, indexReg, jumpSize=ref JumpSize2 }, _, _, list) = (* On x86/32 it might be shorter to use DEC addrReg; ADD addrReg, indexReg. *) Word8Vector.fromList(opAddress(if hostIsX64 then LEAL64 else LEAL32, ~1, addrReg, Index1 indexReg, addrReg)) :: list | fixupAddress(CallAddress(NonAddressConstArg _), brCode, ic, list) = let val brLen = Word8Vector.length brCode in (* Call to the start of the code. Offset is -(bytes to start). *) Word8VectorSlice.concat[ Word8VectorSlice.slice(brCode, 0, SOME(brLen-4)), (* The original opcode. *) Word8VectorSlice.full(Word8Vector.fromList(int32Signed(LargeInt.fromInt(~(Word.toInt ic+brLen))))) ] :: list end | fixupAddress(JumpAddress(NonAddressConstArg _), brCode, ic, list) = let val brLen = Word8Vector.length brCode in (* Call to the start of the code. Offset is -(bytes to start). *) Word8VectorSlice.concat[ Word8VectorSlice.slice(brCode, 0, SOME(brLen-4)), (* The original opcode. *) Word8VectorSlice.full(Word8Vector.fromList(int32Signed(LargeInt.fromInt(~(Word.toInt ic+brLen))))) ] :: list end | fixupAddress(_, bytes, _, list) = bytes :: list fun reprocess(bytesList, lastCodeSize) = let val fixedList = List.rev(foldCode fixupAddress [] (ops, bytesList)) val newCodeSize = setLabelAddresses(ops, fixedList, 0w0) in if newCodeSize = lastCodeSize then (fixedList, lastCodeSize) else if newCodeSize > lastCodeSize then raise InternalError "reprocess - size increased" else reprocess(fixedList, newCodeSize) end in reprocess(bytesList, setLabelAddresses(ops, bytesList, 0w0)) end (* The handling of constants generally differs between 32- and 64-bits. In 32-bits we put all constants inline and the GC processes the code to find the addresss. For real values the "constant" is actually the address of the boxed real value. In 64-bit mode inline constants were used with the MOV instruction but this has now been removed. All constants are stored in one of two areas at the end of the code segment. Non-addresses, including the actual values of reals, are stored in the non-address area and addresses go in the address area. Only the latter is scanned by the GC. The address area is also used in 32-bit mode but only has the address of the function name and the address of the profile ref in it. *) datatype inline32constants = SelfAddress (* The address of the start of the code - inline absolute address 32-bit only *) | InlineAbsoluteAddress of machineWord (* An address in the code: 32-bit only *) | InlineRelativeAddress of machineWord (* A relative address: 32-bit only. *) local (* Turn an integer constant into an 8-byte vector. *) fun intConst ival = LargeWord.fromLargeInt ival (* Copy a real constant from memory into an 8-byte vector. *) fun realConst c = let val cAsAddr = toAddress c (* This may be a boxed real or, in 32-in-64 mode, a boxed float. *) val cLength = length cAsAddr * wordSize val _ = ((cLength = 0w8 orelse cLength = 0w4) andalso flags cAsAddr = F_bytes) orelse raise InternalError "realConst: Not a real number" fun getBytes(i, a) = if i = 0w0 then a else getBytes(i-0w1, a*0w256 + Word8.toLargeWord(loadByte(cAsAddr, i-0w1))) in getBytes(cLength, 0w0) end fun getConstant(Move{ source=NonAddressConstArg source, moveSize=Move32, ...}, bytes, ic, (inl, addr, na)) = if targetArch <> Native32Bit then ( if source >= ~0x80000000 andalso source < 0x100000000 then (* Signed or unsigned 32-bits. *) (inl, addr, na) else (* Too big for 32-bits. *) (inl, addr, (ic + Word.fromInt(Word8Vector.length bytes) - 0w4, intConst source) :: na) ) else (inl, addr, na) (* 32-bit mode. The constant will always be inline even if we've had to use LEA r,c *) | getConstant(Move{ source=NonAddressConstArg source, moveSize=Move64, ...}, bytes, ic, (inl, addr, na)) = if targetArch <> Native32Bit then ( if source >= ~0x80000000 andalso source < 0x100000000 then (* Signed or unsigned 32-bits. *) (inl, addr, na) else (* Too big for 32-bits. *) (inl, addr, (ic + Word.fromInt(Word8Vector.length bytes) - 0w4, intConst source) :: na) ) else (inl, addr, na) (* 32-bit mode. The constant will always be inline even if we've had to use XOR r,r; ADD r,c *) | getConstant(Move{ source=AddressConstArg source, ... }, bytes, ic, (inl, addr, na)) = if targetArch <> Native32Bit then (* Address constants go in the constant area. *) (inl, (ic + Word.fromInt(Word8Vector.length bytes) - 0w4, source) :: addr, na) else ((ic + Word.fromInt(Word8Vector.length bytes) - wordSize, InlineAbsoluteAddress source) :: inl, addr, na) | getConstant(LoadAbsolute{value, ...}, bytes, ic, (inl, addr, na)) = if targetArch = Native64Bit then (* Address constants go in the constant area. *) (inl, (ic + Word.fromInt(Word8Vector.length bytes) - 0w4, value) :: addr, na) (* This is the only case of an inline constant in 32-in-64 *) else ((ic + Word.fromInt(Word8Vector.length bytes) - nativeWordSize, InlineAbsoluteAddress value) :: inl, addr, na) | getConstant(ArithToGenReg{ source=NonAddressConstArg source, ... }, bytes, ic, (inl, addr, na)) = if is32bit source then (inl, addr, na) else (inl, addr, (ic + Word.fromInt(Word8Vector.length bytes) - 0w4, intConst source) :: na) | getConstant(ArithToGenReg{ source=AddressConstArg source, ... }, bytes, ic, (inl, addr, na)) = if hostIsX64 then (inl, (ic + Word.fromInt(Word8Vector.length bytes) - 0w4, source) :: addr, na) else ((ic + Word.fromInt(Word8Vector.length bytes) - 0w4, InlineAbsoluteAddress source) :: inl, addr, na) | getConstant(ArithMemLongConst{ source, ... }, bytes, ic, (inl, addr, na)) = (* 32-bit only. *) ((ic + Word.fromInt(Word8Vector.length bytes) - 0w4, InlineAbsoluteAddress source) :: inl, addr, na) | getConstant(PushToStack(NonAddressConstArg constnt), bytes, ic, (inl, addr, na)) = if is32bit constnt then (inl, addr, na) else (inl, addr, (ic + Word.fromInt(Word8Vector.length bytes) - 0w4, intConst constnt) :: na) | getConstant(PushToStack(AddressConstArg constnt), bytes, ic, (inl, addr, na)) = if targetArch = Native64Bit then (inl, (ic + Word.fromInt(Word8Vector.length bytes) - 0w4, constnt) :: addr, na) else ((ic + Word.fromInt(Word8Vector.length bytes) - 0w4, InlineAbsoluteAddress constnt) :: inl, addr, na) | getConstant(CallAddress(AddressConstArg w), bytes, ic, (inl, addr, na)) = if targetArch = Native64Bit then (inl, (ic + Word.fromInt(Word8Vector.length bytes) - 0w4, w) :: addr, na) else ((ic + Word.fromInt(Word8Vector.length bytes) - 0w4, InlineRelativeAddress w) :: inl, addr, na) | getConstant(JumpAddress(AddressConstArg w), bytes, ic, (inl, addr, na)) = if targetArch = Native64Bit then (inl, (ic + Word.fromInt(Word8Vector.length bytes) - 0w4, w) :: addr, na) else ((ic + Word.fromInt(Word8Vector.length bytes) - 0w4, InlineRelativeAddress w) :: inl, addr, na) | getConstant(LoadLabelAddress _, _, ic, (inl, addr, na)) = (* We need the address of the code itself but it's in the first of a pair of instructions. *) if hostIsX64 then (inl, addr, na) else ((ic + 0w1, SelfAddress) :: inl, addr, na) | getConstant(FPLoadFromConst{constant, ...}, bytes, ic, (inl, addr, na)) = if hostIsX64 then (inl, addr, (ic + Word.fromInt(Word8Vector.length bytes) - 0w4, realConst constant) :: na) else ((ic + Word.fromInt(Word8Vector.length bytes) - 0w4, InlineAbsoluteAddress constant) :: inl, addr, na) | getConstant(FPArithConst{ source, ... }, bytes, ic, (inl, addr, na)) = if hostIsX64 then (inl, addr, (ic + Word.fromInt(Word8Vector.length bytes) - 0w4, realConst source) :: na) else ((ic + Word.fromInt(Word8Vector.length bytes) - 0w4, InlineAbsoluteAddress source) :: inl, addr, na) | getConstant(XMMArith { source=AddressConstArg constVal, ... }, bytes, ic, (inl, addr, na)) = (* Real.real constant or, with 32-bit words, a Real32.real constant. *) if hostIsX64 then (inl, addr, (ic + Word.fromInt(Word8Vector.length bytes) - 0w4, realConst constVal) :: na) else ((ic + Word.fromInt(Word8Vector.length bytes) - 0w4, InlineAbsoluteAddress constVal) :: inl, addr, na) | getConstant(XMMArith { source=NonAddressConstArg constVal, ... }, bytes, ic, (inl, addr, na)) = (* Real32.real constant in native 64-bit. *) (inl, addr, (ic + Word.fromInt(Word8Vector.length bytes) - 0w4, intConst constVal) :: na) | getConstant(MultiplyR{ source=NonAddressConstArg source, ... }, bytes, ic, (inl, addr, na)) = if is32bit source then (inl, addr, na) else (inl, addr, (ic + Word.fromInt(Word8Vector.length bytes) - 0w4, intConst source) :: na) | getConstant(CondMove{ source=NonAddressConstArg source, ... }, bytes, ic, (inl, addr, na)) = if targetArch <> Native32Bit then (inl, addr, (ic + Word.fromInt(Word8Vector.length bytes) - 0w4, intConst source) :: na) else (inl, addr, na) (* 32-bit mode. The constant will always be inline. *) | getConstant(CondMove{ source=AddressConstArg source, ... }, bytes, ic, (inl, addr, na)) = if targetArch <> Native32Bit then (* Address constants go in the constant area. *) (inl, (ic + Word.fromInt(Word8Vector.length bytes) - 0w4, source) :: addr, na) else ((ic + Word.fromInt(Word8Vector.length bytes) - wordSize, InlineAbsoluteAddress source) :: inl, addr, na) | getConstant(_, _, _, l) = l in val getConstants = foldCode getConstant ([], [], []) end (* It is convenient to have AllocStore and AllocStoreVariable as primitives at the higher level but at this point it's better to expand them into their basic instructions. *) fun expandComplexOperations(instrs, oldLabelCount) = let val labelCount = ref oldLabelCount fun mkLabel() = Label{labelNo= !labelCount} before labelCount := !labelCount + 1 (* On X86/64 the local pointer is in r15. On X86/32 it's in memRegs. *) val localPointer = if hostIsX64 then RegisterArg r15 else MemoryArg{base=ebp, offset=memRegLocalMPointer, index=NoIndex} val nativeWordOpSize = if hostIsX64 then OpSize64 else OpSize32 fun allocStoreCommonCode (resultReg, isVarAlloc, regSaveSet: genReg list) = let val compare = ArithToGenReg{opc=CMP, output=resultReg, source=MemoryArg{base=ebp, offset=memRegLocalMbottom, index=NoIndex}, opSize=nativeWordOpSize} (* Normally we won't have run out of store so we want the default branch prediction to skip the test here. However doing that involves adding an extra branch which lengthens the code so it's probably not worth while. *) (* Just checking against the lower limit can fail in the situation where the heap pointer is at the low end of the address range and the store required is so large that the subtraction results in a negative number. In that case it will be > (unsigned) lower_limit so in addition we have to check that the result is < (unsigned) heap_pointer. This actually happened on Windows with X86-64. In theory this can happen with fixed-size allocations as well as variable allocations but in practice fixed-size allocations are going to be small enough that it's not a problem. *) val destLabel = mkLabel() val branches = if isVarAlloc then let val extraLabel = mkLabel() in [ConditionalBranch{test=JB, label=extraLabel}, ArithToGenReg{opc=CMP, output=resultReg, source=localPointer, opSize=nativeWordOpSize}, ConditionalBranch{test=JB, label=destLabel}, JumpLabel extraLabel] end else [ConditionalBranch{test=JNB, label=destLabel}] val callRts = CallRTS{rtsEntry=HeapOverflowCall, saveRegs=regSaveSet} val fixup = JumpLabel destLabel (* Update the heap pointer now we have the store. This is also used by the RTS in the event of a trap to work out how much store was being allocated. *) val update = if hostIsX64 then Move{source=RegisterArg resultReg, destination=RegisterArg r15, moveSize=Move64} else Move{source=RegisterArg resultReg, destination=MemoryArg{base=ebp, offset=memRegLocalMPointer, index=NoIndex}, moveSize=Move32} in compare :: branches @ [callRts, fixup, update] end fun doExpansion([], code, _) = code | doExpansion(AllocStore {size, output, saveRegs} :: instrs, code, inAllocation) = let val _ = inAllocation andalso raise InternalError "doExpansion: Allocation started but not complete" val () = if List.exists (fn r => r = output) saveRegs then raise InternalError "AllocStore: in set" else () val startCode = case targetArch of Native64Bit => let val bytes = (size + 1) * Word.toInt wordSize in [LoadAddress{output=output, offset = ~ bytes, base=SOME r15, index=NoIndex, opSize=OpSize64}] (* TODO: What if it's too big to fit? *) end | Native32Bit => let val bytes = (size + 1) * Word.toInt wordSize in [Move{source=MemoryArg{base=ebp, offset=memRegLocalMPointer, index=NoIndex}, destination=RegisterArg output, moveSize=Move32}, LoadAddress{output=output, offset = ~ bytes, base=SOME output, index=NoIndex, opSize=OpSize32}] end | ObjectId32Bit => let (* We must allocate an even number of words. *) val heapWords = if Int.rem(size, 2) = 1 then size+1 else size+2 val bytes = heapWords * Word.toInt wordSize in [LoadAddress{output=output, offset = ~ bytes, base=SOME r15, index=NoIndex, opSize=OpSize64}] end val resultCode = startCode @ allocStoreCommonCode(output, false, saveRegs) in doExpansion(instrs, (List.rev resultCode) @ code, true) end | doExpansion(AllocStoreVariable {size, output, saveRegs} :: instrs, code, inAllocation) = let (* Allocates memory. The "size" register contains the number of words as a tagged int. *) val _ = inAllocation andalso raise InternalError "doExpansion: Allocation started but not complete" val () = if List.exists (fn r => r = output) saveRegs then raise InternalError "AllocStore: in set" else () (* Negate the length and add it to the current heap pointer. *) (* Compute the number of bytes into dReg. The length in sReg is the number of words as a tagged value so we need to multiply it, add wordSize to include one word for the header then subtract the, multiplied, tag. We use LEA here but want to avoid having an empty base register. *) val _ = size = output andalso raise InternalError "AllocStoreVariable : same register for size and output" val startCode = if wordSize = 0w8 (* 8-byte words *) then [ ArithToGenReg{opc=XOR, output=output, source=RegisterArg output, opSize=OpSize32 (* Rest is zeroed *)}, ArithToGenReg{opc=SUB, output=output, source=RegisterArg size, opSize=OpSize64}, LoadAddress{output=output, base=SOME r15, offset= ~(Word.toInt wordSize-4), index=Index4 output, opSize=OpSize64 } ] else (* 4 byte words *) [ LoadAddress{output=output, base=SOME size, offset=Word.toInt wordSize-2, index=Index1 size, opSize=nativeWordOpSize }, Negative{output=output, opSize=nativeWordOpSize}, ArithToGenReg{opc=ADD, output=output, source=localPointer, opSize=nativeWordOpSize} ] (* If this is 32-in-64 we need to round down to the next 8-byte boundary. *) val roundCode = if targetArch = ObjectId32Bit then [ArithToGenReg{opc=AND, output=output, source=NonAddressConstArg ~8, opSize=OpSize64 }] else [] val resultCode = startCode @ roundCode @ allocStoreCommonCode(output, true, saveRegs) in doExpansion(instrs, (List.rev resultCode) @ code, true) end | doExpansion(StoreInitialised :: instrs, code, _) = doExpansion(instrs, code, false) | doExpansion(instr :: instrs, code, inAlloc) = doExpansion(instrs, instr::code, inAlloc) val expanded = List.rev(doExpansion(instrs, [], false)) in (expanded, !labelCount) end fun printCode (Code{procName, printStream, ...}, seg) = let val print = printStream val ptr = ref 0w0; (* prints a string representation of a number *) fun printValue v = if v < 0 then (print "-"; print(LargeInt.toString (~ v))) else print(LargeInt.toString v) infix 3 +:= ; fun (x +:= y) = (x := !x + (y:word)); fun get16s (a, seg) : int = let val b0 = Word8.toInt (codeVecGet (seg, a)); val b1 = Word8.toInt (codeVecGet (seg, a + 0w1)); val b1' = if b1 >= 0x80 then b1 - 0x100 else b1; in (b1' * 0x100) + b0 end fun get16u(a, seg) : int = Word8.toInt (codeVecGet (seg, a + 0w1)) * 0x100 + Word8.toInt (codeVecGet (seg, a)) (* Get 1 unsigned byte from the given offset in the segment. *) fun get8u (a, seg) : Word8.word = codeVecGet (seg, a); (* Get 1 signed byte from the given offset in the segment. *) fun get8s (a, seg) : int = Word8.toIntX (codeVecGet (seg, a)); (* Get 1 signed 32 bit word from the given offset in the segment. *) fun get32s (a, seg) : LargeInt.int = let val b0 = Word8.toLargeInt (codeVecGet (seg, a)); val b1 = Word8.toLargeInt (codeVecGet (seg, a + 0w1)); val b2 = Word8.toLargeInt (codeVecGet (seg, a + 0w2)); val b3 = Word8.toLargeInt (codeVecGet (seg, a + 0w3)); val b3' = if b3 >= 0x80 then b3 - 0x100 else b3; val topHw = (b3' * 0x100) + b2; val bottomHw = (b1 * 0x100) + b0; in (topHw * exp2_16) + bottomHw end fun get64s (a, seg) : LargeInt.int = let val b0 = Word8.toLargeInt (codeVecGet (seg, a)); val b1 = Word8.toLargeInt (codeVecGet (seg, a + 0w1)); val b2 = Word8.toLargeInt (codeVecGet (seg, a + 0w2)); val b3 = Word8.toLargeInt (codeVecGet (seg, a + 0w3)); val b4 = Word8.toLargeInt (codeVecGet (seg, a + 0w4)); val b5 = Word8.toLargeInt (codeVecGet (seg, a + 0w5)); val b6 = Word8.toLargeInt (codeVecGet (seg, a + 0w6)); val b7 = Word8.toLargeInt (codeVecGet (seg, a + 0w7)); val b7' = if b7 >= 0x80 then b7 - 0x100 else b7; in ((((((((b7' * 0x100 + b6) * 0x100 + b5) * 0x100 + b4) * 0x100 + b3) * 0x100 + b2) * 0x100) + b1) * 0x100) + b0 end fun print32 () = printValue (get32s (!ptr, seg)) before (ptr +:= 0w4) and print64 () = printValue (get64s (!ptr, seg)) before (ptr +:= 0w8) and print16 () = printValue (LargeInt.fromInt(get16s (!ptr, seg)) before (ptr +:= 0w2)) and print8 () = printValue (LargeInt.fromInt(get8s (!ptr, seg)) before (ptr +:= 0w1)) fun printJmp () = let val valu = get8s (!ptr, seg) before ptr +:= 0w1 in print (Word.fmt StringCvt.HEX (Word.fromInt valu + !ptr)) end (* Print an effective address. The register field may designate a general register or an xmm register depending on the instruction. *) fun printEAGeneral printRegister (rex, sz) = let val modrm = codeVecGet (seg, !ptr) val () = ptr +:= 0w1 (* Decode the Rex prefix if present. *) val rexX = (rex andb8 0wx2) <> 0w0 val rexB = (rex andb8 0wx1) <> 0w0 val prefix = case sz of SZByte => "byte ptr " | SZWord => "word ptr " | SZDWord => "dword ptr " | SZQWord => "qword ptr " in case (modrm >>- 0w6, modrm andb8 0w7, hostIsX64) of (0w3, rm, _) => printRegister(rm, rexB, sz) | (md, 0w4, _) => let (* s-i-b present. *) val sib = codeVecGet (seg, !ptr) val () = ptr +:= 0w1 val ss = sib >>- 0w6 val index = (sib >>- 0w3) andb8 0w7 val base = sib andb8 0w7 in print prefix; case (md, base, hostIsX64) of (0w1, _, _) => print8 () | (0w2, _, _) => print32 () | (0w0, 0w5, _) => print32 () (* Absolute in 32-bit mode. PC-relative in 64-bit ?? *) | _ => (); print "["; if md <> 0w0 orelse base <> 0w5 then ( print (genRegRepr (mkReg (base, rexB), sz32_64)); if index = 0w4 then () else print "," ) else (); if index = 0w4 andalso not rexX (* No index. *) then () else print (genRegRepr (mkReg(index, rexX), sz32_64) ^ (if ss = 0w0 then "*1" else if ss = 0w1 then "*2" else if ss = 0w2 then "*4" else "*8")); print "]" end | (0w0, 0w5, false) => (* Absolute address.*) (print prefix; print32 ()) | (0w0, 0w5, _) => (* PC-relative in 64-bit *) (print prefix; print ".+"; print32 ()) | (md, rm, _) => (* register plus offset. *) ( print prefix; if md = 0w1 then print8 () else if md = 0w2 then print32 () else (); print ("[" ^ genRegRepr (mkReg(rm, rexB), sz32_64) ^ "]") ) end (* For most instructions we want to print a general register. *) val printEA = printEAGeneral (fn (rm, rexB, sz) => print (genRegRepr (mkReg(rm, rexB), sz))) and printEAxmm = printEAGeneral (fn (rm, _, _) => print (xmmRegRepr(SSE2Reg rm))) fun printArith opc = print (case opc of 0 => "add " | 1 => "or " | 2 => "adc " | 3 => "sbb " | 4 => "and " | 5 => "sub " | 6 => "xor " | _ => "cmp " ) fun printGvEv (opByte, rex, rexR, sz) = let (* Register is in next byte. *) val nb = codeVecGet (seg, !ptr) val reg = (nb >>- 0w3) andb8 0w7 in printArith(Word8.toInt((opByte div 0w8) mod 0w8)); print "\t"; print (genRegRepr (mkReg(reg, rexR), sz)); print ","; printEA(rex, sz) end fun printMovCToR (opByte, sz, rexB) = ( print "mov \t"; print(genRegRepr (mkReg (opByte mod 0w8, rexB), sz)); print ","; case sz of SZDWord => print32 () | SZQWord => print64 () | _ => print "???" ) fun printShift (opByte, rex, sz) = let (* Opcode is determined by next byte. *) val nb = Word8.toInt (codeVecGet (seg, !ptr)) val opc = (nb div 8) mod 8 in print (case opc of 4 => "shl " | 5 => "shr " | 7 => "sar " | _ => "???" ); print "\t"; printEA(rex, sz); print ","; if opByte = opToInt Group2_1_A32 then print "1" else if opByte = opToInt Group2_CL_A32 then print "cl" else print8 () end fun printFloat (opByte, rex) = let (* Opcode is in next byte. *) val opByte2 = codeVecGet (seg, !ptr) val nnn = (opByte2 >>- 0w3) andb8 0w7 val escNo = opByte andb8 0wx7 in if (opByte2 andb8 0wxC0) = 0wxC0 then (* mod = 11 *) ( case (escNo, nnn, opByte2 andb8 0wx7 (* modrm *)) of (0w1, 0w4, 0w0) => print "fchs" | (0w1, 0w4, 0w1) => print "fabs" | (0w1, 0w5, 0w6) => print "fldz" | (0w1, 0w5, 0w1) => print "flf1" | (0w7, 0w4, 0w0) => print "fnstsw\tax" | (0w1, 0w5, 0w0) => print "fld1" | (0w1, 0w6, 0w3) => print "fpatan" | (0w1, 0w7, 0w2) => print "fsqrt" | (0w1, 0w7, 0w6) => print "fsin" | (0w1, 0w7, 0w7) => print "fcos" | (0w1, 0w6, 0w7) => print "fincstp" | (0w1, 0w6, 0w6) => print "fdecstp" | (0w3, 0w4, 0w2) => print "fnclex" | (0w5, 0w2, rno) => print ("fst \tst(" ^ Word8.toString rno ^ ")") | (0w5, 0w3, rno) => print ("fstp\tst(" ^ Word8.toString rno ^ ")") | (0w1, 0w0, rno) => print ("fld \tst(" ^ Word8.toString rno ^ ")") | (0w1, 0w1, rno) => print ("fxch\tst(" ^ Word8.toString rno ^ ")") | (0w0, 0w3, rno) => print ("fcomp\tst(" ^ Word8.toString rno ^ ")") | (0w0, 0w0, rno) => print ("fadd\tst,st(" ^ Word8.toString rno ^ ")") | (0w0, 0w1, rno) => print ("fmul\tst,st(" ^ Word8.toString rno ^ ")") | (0w0, 0w4, rno) => print ("fsub\tst,st(" ^ Word8.toString rno ^ ")") | (0w0, 0w5, rno) => print ("fsubr\tst,st(" ^ Word8.toString rno ^ ")") | (0w0, 0w6, rno) => print ("fdiv\tst,st(" ^ Word8.toString rno ^ ")") | (0w0, 0w7, rno) => print ("fdivr\tst,st(" ^ Word8.toString rno ^ ")") | (0w5, 0w0, rno) => print ("ffree\tst(" ^ Word8.toString rno ^ ")") | _ => (printValue(Word8.toLargeInt opByte); printValue(Word8.toLargeInt opByte2)); ptr +:= 0w1 ) else (* mod = 00, 01, 10 *) ( case (escNo, nnn) of (0w0, 0w0) => (print "fadd\t"; printEA(rex, SZDWord)) (* Single precision. *) | (0w0, 0w1) => (print "fmul\t"; printEA(rex, SZDWord)) | (0w0, 0w3) => (print "fcomp\t"; printEA(rex, SZDWord)) | (0w0, 0w4) => (print "fsub\t"; printEA(rex, SZDWord)) | (0w0, 0w5) => (print "fsubr\t"; printEA(rex, SZDWord)) | (0w0, 0w6) => (print "fdiv\t"; printEA(rex, SZDWord)) | (0w0, 0w7) => (print "fdivr\t"; printEA(rex, SZDWord)) | (0w1, 0w0) => (print "fld \t"; printEA(rex, SZDWord)) | (0w1, 0w2) => (print "fst\t"; printEA(rex, SZDWord)) | (0w1, 0w3) => (print "fstp\t"; printEA(rex, SZDWord)) | (0w1, 0w5) => (print "fldcw\t"; printEA(rex, SZWord)) (* Control word is 16 bits *) | (0w1, 0w7) => (print "fstcw\t"; printEA(rex, SZWord)) (* Control word is 16 bits *) | (0w3, 0w0) => (print "fild\t"; printEA(rex, SZDWord)) (* 32-bit int. *) | (0w7, 0w5) => (print "fild\t"; printEA(rex, SZQWord)) (* 64-bit int. *) | (0w3, 0w3) => (print "fistp\t"; printEA(rex, SZDWord)) (* 32-bit int. *) | (0w7, 0w7) => (print "fistp\t"; printEA(rex, SZQWord)) (* 64-bit int. *) | (0w4, 0w0) => (print "fadd\t"; printEA(rex, SZQWord)) (* Double precision. *) | (0w4, 0w1) => (print "fmul\t"; printEA(rex, SZQWord)) | (0w4, 0w3) => (print "fcomp\t"; printEA(rex, SZQWord)) | (0w4, 0w4) => (print "fsub\t"; printEA(rex, SZQWord)) | (0w4, 0w5) => (print "fsubr\t"; printEA(rex, SZQWord)) | (0w4, 0w6) => (print "fdiv\t"; printEA(rex, SZQWord)) | (0w4, 0w7) => (print "fdivr\t"; printEA(rex, SZQWord)) | (0w5, 0w0) => (print "fld \t"; printEA(rex, SZQWord)) | (0w5, 0w2) => (print "fst\t"; printEA(rex, SZQWord)) | (0w5, 0w3) => (print "fstp\t"; printEA(rex, SZQWord)) | _ => (printValue(Word8.toLargeInt opByte); printValue(Word8.toLargeInt opByte2)) ) end fun printJmp32 oper = let val valu = get32s (!ptr, seg) before (ptr +:= 0w4) in print oper; print "\t"; print (Word.fmt StringCvt.HEX (!ptr + Word.fromLargeInt valu)) end fun printMask mask = let val wordMask = Word.fromInt mask fun printAReg n = if n = regs then () else ( if (wordMask andb (0w1 << Word.fromInt n)) <> 0w0 then (print(regRepr(regN n)); print " ") else (); printAReg(n+1) ) in printAReg 0 end in if procName = "" (* No name *) then print "?" else print procName; print ":\n"; while get8u (!ptr, seg) <> 0wxf4 (* HLT. *) do let val () = print (Word.fmt StringCvt.HEX (!ptr)) (* The address in hex. *) val () = print "\t" (* See if we have a lock prefix. *) val () = if get8u (!ptr, seg) = 0wxF0 then (print "lock "; ptr := !ptr + 0w1) else () val legacyPrefix = let val p = get8u (!ptr, seg) in if p = 0wxF2 orelse p = 0wxF3 orelse p = 0wx66 then (ptr := !ptr + 0w1; p) else 0wx0 end (* See if we have a REX byte. *) val rex = let val b = get8u (!ptr, seg); in if b >= 0wx40 andalso b <= 0wx4f then (ptr := !ptr + 0w1; b) else 0w0 end val rexW = (rex andb8 0wx8) <> 0w0 val rexR = (rex andb8 0wx4) <> 0w0 val rexB = (rex andb8 0wx1) <> 0w0 val opByte = get8u (!ptr, seg) before ptr +:= 0w1 val sizeFromRexW = if rexW then SZQWord else SZDWord in case opByte of 0wx03 => printGvEv (opByte, rex, rexR, sizeFromRexW) | 0wx0b => printGvEv (opByte, rex, rexR, sizeFromRexW) | 0wx0f => (* ESCAPE *) let (* Opcode is in next byte. *) val opByte2 = codeVecGet (seg, !ptr) val () = (ptr +:= 0w1) fun printcmov movop = let val nb = codeVecGet (seg, !ptr) val reg = (nb >>- 0w3) andb8 0w7 in print movop; print "\t"; print (genRegRepr (mkReg(reg, rexR), sizeFromRexW)); print ","; printEA(rex, sizeFromRexW) end in case legacyPrefix of 0w0 => ( case opByte2 of 0wx2e => let (* ucomiss doesn't have a prefix. *) val nb = codeVecGet (seg, !ptr) val reg = SSE2Reg((nb >>- 0w3) andb8 0w7) in print "ucomiss\t"; print(xmmRegRepr reg); print ","; printEAxmm(rex, SZDWord) end | 0wx40 => printcmov "cmovo" | 0wx41 => printcmov "cmovno" | 0wx42 => printcmov "cmovb" | 0wx43 => printcmov "cmovnb" | 0wx44 => printcmov "cmove" | 0wx45 => printcmov "cmovne" | 0wx46 => printcmov "cmovna" | 0wx47 => printcmov "cmova" | 0wx48 => printcmov "cmovs" | 0wx49 => printcmov "cmovns" | 0wx4a => printcmov "cmovp" | 0wx4b => printcmov "cmovnp" | 0wx4c => printcmov "cmovl" | 0wx4d => printcmov "cmovge" | 0wx4e => printcmov "cmovle" | 0wx4f => printcmov "cmovg" | 0wxC1 => let val nb = codeVecGet (seg, !ptr); val reg = (nb >>- 0w3) andb8 0w7 in (* The address argument comes first in the assembly code. *) print "xadd\t"; printEA (rex, sizeFromRexW); print ","; print (genRegRepr (mkReg(reg, rexR), sizeFromRexW)) end | 0wxB6 => let val nb = codeVecGet (seg, !ptr); val reg = (nb >>- 0w3) andb8 0w7 in print "movzx\t"; print (genRegRepr (mkReg(reg, rexR), sizeFromRexW)); print ","; printEA (rex, SZByte) end | 0wxB7 => let val nb = codeVecGet (seg, !ptr); val reg = (nb >>- 0w3) andb8 0w7 in print "movzx\t"; print (genRegRepr (mkReg(reg, rexR), sizeFromRexW)); print ","; printEA (rex, SZWord) end | 0wxBE => let val nb = codeVecGet (seg, !ptr); val reg = (nb >>- 0w3) andb8 0w7 in print "movsx\t"; print (genRegRepr (mkReg(reg, rexR), sizeFromRexW)); print ","; printEA (rex, SZByte) end | 0wxBF => let val nb = codeVecGet (seg, !ptr); val reg = (nb >>- 0w3) andb8 0w7 in print "movsx\t"; print (genRegRepr (mkReg(reg, rexR), sizeFromRexW)); print ","; printEA (rex, SZWord) end | 0wxAE => let (* Opcode is determined by the next byte. *) val opByte2 = codeVecGet (seg, !ptr); val nnn = (opByte2 >>- 0w3) andb8 0w7 in case nnn of 0wx2 => (print "ldmxcsr\t"; printEA(rex, SZDWord)) | 0wx3 => (print "stmxcsr\t"; printEA(rex, SZDWord)) | _ => (printValue(Word8.toLargeInt opByte); printValue(Word8.toLargeInt opByte2)) end | 0wxAF => let val nb = codeVecGet (seg, !ptr); val reg = (nb >>- 0w3) andb8 0w7 in print "imul\t"; print (genRegRepr (mkReg(reg, rexR), sizeFromRexW)); print ","; printEA (rex, sizeFromRexW) end | 0wx80 => printJmp32 "jo " | 0wx81 => printJmp32 "jno " | 0wx82 => printJmp32 "jb " | 0wx83 => printJmp32 "jnb " | 0wx84 => printJmp32 "je " | 0wx85 => printJmp32 "jne " | 0wx86 => printJmp32 "jna " | 0wx87 => printJmp32 "ja " | 0wx88 => printJmp32 "js " | 0wx89 => printJmp32 "jns " | 0wx8a => printJmp32 "jp " | 0wx8b => printJmp32 "jnp " | 0wx8c => printJmp32 "jl " | 0wx8d => printJmp32 "jge " | 0wx8e => printJmp32 "jle " | 0wx8f => printJmp32 "jg " | 0wx90 => (print "seto\t"; printEA (rex, SZByte)) | 0wx91 => (print "setno\t"; printEA (rex, SZByte)) | 0wx92 => (print "setb\t"; printEA (rex, SZByte)) | 0wx93 => (print "setnb\t"; printEA (rex, SZByte)) | 0wx94 => (print "sete\t"; printEA (rex, SZByte)) | 0wx95 => (print "setne\t"; printEA (rex, SZByte)) | 0wx96 => (print "setna\t"; printEA (rex, SZByte)) | 0wx97 => (print "seta\t"; printEA (rex, SZByte)) | 0wx98 => (print "sets\t"; printEA (rex, SZByte)) | 0wx99 => (print "setns\t"; printEA (rex, SZByte)) | 0wx9a => (print "setp\t"; printEA (rex, SZByte)) | 0wx9b => (print "setnp\t"; printEA (rex, SZByte)) | 0wx9c => (print "setl\t"; printEA (rex, SZByte)) | 0wx9d => (print "setge\t"; printEA (rex, SZByte)) | 0wx9e => (print "setle\t"; printEA (rex, SZByte)) | 0wx9f => (print "setg\t"; printEA (rex, SZByte)) | _ => (print "esc\t"; printValue(Word8.toLargeInt opByte2)) ) | 0wxf2 => (* SSE2 instruction *) let val nb = codeVecGet (seg, !ptr) val rr = (nb >>- 0w3) andb8 0w7 val reg = SSE2Reg rr in case opByte2 of 0wx10 => ( print "movsd\t"; print(xmmRegRepr reg); print ","; printEAxmm(rex, SZQWord) ) | 0wx11 => ( print "movsd\t"; printEAxmm(rex, SZQWord); print ","; print(xmmRegRepr reg) ) | 0wx2a => ( print "cvtsi2sd\t"; print(xmmRegRepr reg); print ","; printEA(rex, sizeFromRexW) ) | 0wx2c => ( print "cvttsd2si\t"; print (genRegRepr (mkReg(rr, rexR), sizeFromRexW)); print ","; printEAxmm(rex, sizeFromRexW) ) | 0wx2d => ( print "cvtsd2si\t"; print (genRegRepr (mkReg(rr, rexR), sizeFromRexW)); print ","; printEAxmm(rex, sizeFromRexW) ) | 0wx58 => ( print "addsd\t"; print(xmmRegRepr reg); print ","; printEAxmm(rex, SZQWord) ) | 0wx59 => ( print "mulsd\t"; print(xmmRegRepr reg); print ","; printEAxmm(rex, SZQWord) ) | 0wx5a => ( print "cvtsd2ss\t"; print(xmmRegRepr reg); print ","; printEAxmm(rex, SZQWord) ) | 0wx5c => ( print "subsd\t"; print(xmmRegRepr reg); print ","; printEAxmm(rex, SZQWord) ) | 0wx5e => ( print "divsd\t"; print(xmmRegRepr reg); print ","; printEAxmm(rex, SZQWord) ) | b => (print "F2\n"; print "0F\n"; print(Word8.fmt StringCvt.HEX b)) end | 0wxf3 => (* SSE2 instruction. *) let val nb = codeVecGet (seg, !ptr) val rr = (nb >>- 0w3) andb8 0w7 val reg = SSE2Reg rr in case opByte2 of 0wx10 => ( print "movss\t"; print(xmmRegRepr reg); print ","; printEAxmm(rex, SZDWord) ) | 0wx11 => ( print "movss\t"; printEAxmm(rex, SZDWord); print ","; print(xmmRegRepr reg) ) | 0wx2c => ( print "cvttss2si\t"; print (genRegRepr (mkReg(rr, rexR), sizeFromRexW)); print ","; printEAxmm(rex, sizeFromRexW) ) | 0wx2d => ( print "cvtss2si\t"; print (genRegRepr (mkReg(rr, rexR), sizeFromRexW)); print ","; printEAxmm(rex, sizeFromRexW) ) | 0wx5a => ( print "cvtss2sd\t"; print(xmmRegRepr reg); print ","; printEAxmm(rex, SZDWord) ) | 0wx58 => ( print "addss\t"; print(xmmRegRepr reg); print ","; printEAxmm(rex, SZDWord) ) | 0wx59 => ( print "mulss\t"; print(xmmRegRepr reg); print ","; printEAxmm(rex, SZDWord) ) | 0wx5c => ( print "subss\t"; print(xmmRegRepr reg); print ","; printEAxmm(rex, SZDWord) ) | 0wx5e => ( print "divss\t"; print(xmmRegRepr reg); print ","; printEAxmm(rex, SZDWord) ) | b => (print "F3\n"; print "0F\n"; print(Word8.fmt StringCvt.HEX b)) end | 0wx66 => (* SSE2 instruction *) let val nb = codeVecGet (seg, !ptr) val reg = SSE2Reg((nb >>- 0w3) andb8 0w7) in case opByte2 of 0wx2e => ( print "ucomisd\t"; print(xmmRegRepr reg); print ","; printEAxmm(rex, SZQWord) ) | 0wx54 => ( print "andpd\t"; print(xmmRegRepr reg); print ","; printEAxmm(rex, SZQWord) ) | 0wx57 => ( print "xorpd\t"; print(xmmRegRepr reg); print ","; printEAxmm(rex, SZQWord) ) | 0wx6e => ( print (if rexW then "movq\t" else "movd\t"); print(xmmRegRepr reg); print ","; printEA(rex, sizeFromRexW) ) | 0wx7e => ( print (if rexW then "movq\t" else "movd\t"); printEA(rex, sizeFromRexW); print ","; print(xmmRegRepr reg) ) | 0wx73 => ( print "psrldq\t"; printEAxmm(rex, SZQWord); print ","; print8 ()) | b => (print "66\n"; print "0F\n"; print(Word8.fmt StringCvt.HEX b)) end | _ => (print "esc\t"; printValue(Word8.toLargeInt opByte2)) end (* ESCAPE *) | 0wx13 => printGvEv (opByte, rex, rexR, sizeFromRexW) | 0wx1b => printGvEv (opByte, rex, rexR, sizeFromRexW) | 0wx23 => printGvEv (opByte, rex, rexR, sizeFromRexW) | 0wx2b => printGvEv (opByte, rex, rexR, sizeFromRexW) | 0wx33 => printGvEv (opByte, rex, rexR, sizeFromRexW) | 0wx3b => printGvEv (opByte, rex, rexR, sizeFromRexW) (* Push and Pop. These are 64-bit on X86/64 whether there is REX prefix or not. *) | 0wx50 => print ("push\t" ^ genRegRepr (mkReg (opByte mod 0w8, rexB), sz32_64)) | 0wx51 => print ("push\t" ^ genRegRepr (mkReg (opByte mod 0w8, rexB), sz32_64)) | 0wx52 => print ("push\t" ^ genRegRepr (mkReg (opByte mod 0w8, rexB), sz32_64)) | 0wx53 => print ("push\t" ^ genRegRepr (mkReg (opByte mod 0w8, rexB), sz32_64)) | 0wx54 => print ("push\t" ^ genRegRepr (mkReg (opByte mod 0w8, rexB), sz32_64)) | 0wx55 => print ("push\t" ^ genRegRepr (mkReg (opByte mod 0w8, rexB), sz32_64)) | 0wx56 => print ("push\t" ^ genRegRepr (mkReg (opByte mod 0w8, rexB), sz32_64)) | 0wx57 => print ("push\t" ^ genRegRepr (mkReg (opByte mod 0w8, rexB), sz32_64)) | 0wx58 => print ("pop \t" ^ genRegRepr (mkReg (opByte mod 0w8, rexB), sz32_64)) | 0wx59 => print ("pop \t" ^ genRegRepr (mkReg (opByte mod 0w8, rexB), sz32_64)) | 0wx5a => print ("pop \t" ^ genRegRepr (mkReg (opByte mod 0w8, rexB), sz32_64)) | 0wx5b => print ("pop \t" ^ genRegRepr (mkReg (opByte mod 0w8, rexB), sz32_64)) | 0wx5c => print ("pop \t" ^ genRegRepr (mkReg (opByte mod 0w8, rexB), sz32_64)) | 0wx5d => print ("pop \t" ^ genRegRepr (mkReg (opByte mod 0w8, rexB), sz32_64)) | 0wx5e => print ("pop \t" ^ genRegRepr (mkReg (opByte mod 0w8, rexB), sz32_64)) | 0wx5f => print ("pop \t" ^ genRegRepr (mkReg (opByte mod 0w8, rexB), sz32_64)) | 0wx63 => (* MOVSXD. This is ARPL in 32-bit mode but that's never used here. *) let val nb = codeVecGet (seg, !ptr) val reg = (nb >>- 0w3) andb8 0w7 in print "movsxd\t"; print (genRegRepr (mkReg(reg, rexR), sizeFromRexW)); print ","; printEA(rex, SZDWord) end | 0wx68 => (print "push\t"; print32 ()) | 0wx69 => let (* Register is in next byte. *) val nb = codeVecGet (seg, !ptr) val reg = (nb >>- 0w3) andb8 0w7 in print "imul\t"; print(genRegRepr (mkReg(reg, rexR), sizeFromRexW)); print ","; printEA(rex, sizeFromRexW); print ","; print32 () end | 0wx6a => (print "push\t"; print8 ()) | 0wx6b => let (* Register is in next byte. *) val nb = codeVecGet (seg, !ptr) val reg = (nb >>- 0w3) andb8 0w7 in print "imul\t"; print(genRegRepr (mkReg(reg, rexR), sizeFromRexW)); print ","; printEA(rex, sizeFromRexW); print ","; print8 () end | 0wx70 => (print "jo \t"; printJmp()) | 0wx71 => (print "jno \t"; printJmp()) | 0wx72 => (print "jb \t"; printJmp()) | 0wx73 => (print "jnb \t"; printJmp()) | 0wx74 => (print "je \t"; printJmp()) | 0wx75 => (print "jne \t"; printJmp()) | 0wx76 => (print "jna \t"; printJmp()) | 0wx77 => (print "ja \t"; printJmp()) | 0wx78 => (print "js \t"; printJmp()) | 0wx79 => (print "jns \t"; printJmp()) | 0wx7a => (print "jp \t"; printJmp()) | 0wx7b => (print "jnp \t"; printJmp()) | 0wx7c => (print "jl \t"; printJmp()) | 0wx7d => (print "jge \t"; printJmp()) | 0wx7e => (print "jle \t"; printJmp()) | 0wx7f => (print "jg \t"; printJmp()) | 0wx80 => (* Group1_8_a *) let (* Memory, byte constant *) (* Opcode is determined by next byte. *) val nb = Word8.toInt (codeVecGet (seg, !ptr)) in printArith ((nb div 8) mod 8); print "\t"; printEA(rex, SZByte); print ","; print8 () end | 0wx81 => let (* Memory, 32-bit constant *) (* Opcode is determined by next byte. *) val nb = Word8.toInt (codeVecGet (seg, !ptr)) in printArith ((nb div 8) mod 8); print "\t"; printEA(rex, sizeFromRexW); print ","; print32 () end | 0wx83 => let (* Word memory, 8-bit constant *) (* Opcode is determined by next byte. *) val nb = Word8.toInt (codeVecGet (seg, !ptr)) in printArith ((nb div 8) mod 8); print "\t"; printEA(rex, sizeFromRexW); print ","; print8 () end | 0wx87 => let (* xchng *) (* Register is in next byte. *) val nb = codeVecGet (seg, !ptr) val reg = (nb >>- 0w3) andb8 0w7 in print "xchng \t"; printEA(rex, sizeFromRexW); print ","; print (genRegRepr (mkReg(reg, rexR), sizeFromRexW)) end | 0wx88 => let (* mov eb,gb i.e a store *) (* Register is in next byte. *) val nb = Word8.toInt (codeVecGet (seg, !ptr)); val reg = (nb div 8) mod 8; in print "mov \t"; printEA(rex, SZByte); print ","; if rexR then print ("r" ^ Int.toString(reg+8) ^ "B") else case reg of 0 => print "al" | 1 => print "cl" | 2 => print "dl" | 3 => print "bl" (* If there is a REX byte these select the low byte of the registers. *) | 4 => print (if rex = 0w0 then "ah" else "sil") | 5 => print (if rex = 0w0 then "ch" else "dil") | 6 => print (if rex = 0w0 then "dh" else "bpl") | 7 => print (if rex = 0w0 then "bh" else "spl") | _ => print ("r" ^ Int.toString reg) end | 0wx89 => let (* mov ev,gv i.e. a store *) (* Register is in next byte. *) val nb = codeVecGet (seg, !ptr) val reg = (nb >>- 0w3) andb8 0w7 in print "mov \t"; (* This may have an opcode prefix. *) printEA(rex, if legacyPrefix = 0wx66 then SZWord else sizeFromRexW); print ","; print (genRegRepr (mkReg(reg, rexR), sizeFromRexW)) end | 0wx8b => let (* mov gv,ev i.e. a load *) (* Register is in next byte. *) val nb = codeVecGet (seg, !ptr) val reg = (nb >>- 0w3) andb8 0w7 in print "mov \t"; print (genRegRepr (mkReg(reg, rexR), sizeFromRexW)); print ","; printEA(rex, sizeFromRexW) end | 0wx8d => let (* lea gv.M *) (* Register is in next byte. *) val nb = codeVecGet (seg, !ptr) val reg = (nb >>- 0w3) andb8 0w7 in print "lea \t"; print (genRegRepr (mkReg(reg, rexR), sizeFromRexW)); print ","; printEA(rex, sizeFromRexW) end | 0wx8f => (print "pop \t"; printEA(rex, sz32_64)) | 0wx90 => print "nop" | 0wx99 => if rexW then print "cqo" else print "cdq" | 0wx9e => print "sahf\n" | 0wxa4 => (if legacyPrefix = 0wxf3 then print "rep " else (); print "movsb") | 0wxa5 => (if legacyPrefix = 0wxf3 then print "rep " else (); print "movsl") | 0wxa6 => (if legacyPrefix = 0wxf3 then print "repe " else (); print "cmpsb") | 0wxa8 => (print "test\tal,"; print8 ()) | 0wxaa => (if legacyPrefix = 0wxf3 then print "rep " else (); print "stosb") | 0wxab => ( if legacyPrefix = 0wxf3 then print "rep " else (); if rexW then print "stosq" else print "stosl" ) | 0wxb8 => printMovCToR (opByte, sizeFromRexW, rexB) | 0wxb9 => printMovCToR (opByte, sizeFromRexW, rexB) | 0wxba => printMovCToR (opByte, sizeFromRexW, rexB) | 0wxbb => printMovCToR (opByte, sizeFromRexW, rexB) | 0wxbc => printMovCToR (opByte, sizeFromRexW, rexB) | 0wxbd => printMovCToR (opByte, sizeFromRexW, rexB) | 0wxbe => printMovCToR (opByte, sizeFromRexW, rexB) | 0wxbf => printMovCToR (opByte, sizeFromRexW, rexB) | 0wxc1 => (* Group2_8_A *) printShift (opByte, rex, sizeFromRexW) | 0wxc2 => (print "ret \t"; print16 ()) | 0wxc3 => print "ret" | 0wxc6 => (* move 8-bit constant to memory *) ( print "mov \t"; printEA(rex, SZByte); print ","; print8 () ) | 0wxc7 => (* move 32/64-bit constant to memory *) ( print "mov \t"; printEA(rex, sizeFromRexW); print ","; print32 () ) | 0wxca => (* Register mask *) let val mask = get16u (!ptr, seg) before (ptr +:= 0w2) in print "SAVE\t"; printMask mask end | 0wxcd => (* Register mask *) let val mask = get8u (!ptr, seg) before (ptr +:= 0w1) in print "SAVE\t"; printMask(Word8.toInt mask) end | 0wxd1 => (* Group2_1_A *) printShift (opByte, rex, sizeFromRexW) | 0wxd3 => (* Group2_CL_A *) printShift (opByte, rex, sizeFromRexW) | 0wxd8 => printFloat (opByte, rex) (* Floating point escapes *) | 0wxd9 => printFloat (opByte, rex) | 0wxda => printFloat (opByte, rex) | 0wxdb => printFloat (opByte, rex) | 0wxdc => printFloat (opByte, rex) | 0wxdd => printFloat (opByte, rex) | 0wxde => printFloat (opByte, rex) | 0wxdf => printFloat (opByte, rex) | 0wxe8 => let (* 32-bit relative call. *) val valu = get32s (!ptr, seg) before (ptr +:= 0w4) in print "call\t"; print (Word.fmt StringCvt.HEX (!ptr + Word.fromLargeInt valu)) end | 0wxe9 => let (* 32-bit relative jump. *) val valu = get32s (!ptr, seg) before (ptr +:= 0w4) in print "jmp \t"; print (Word.fmt StringCvt.HEX (!ptr + Word.fromLargeInt valu)) end | 0wxeb => (print "jmp \t"; printJmp()) | 0wxf4 => print "hlt" (* Marker to indicate end-of-code. *) | 0wxf6 => (* Group3_a *) let (* Opcode is determined by next byte. *) val nb = Word8.toInt (codeVecGet (seg, !ptr)) val opc = (nb div 8) mod 8 in print (case opc of 0 => "test" | 3 => "neg" | _ => "???" ); print "\t"; printEA(rex, SZByte); if opc = 0 then (print ","; print8 ()) else () end | 0wxf7 => (* Group3_A *) let (* Opcode is determined by next byte. *) val nb = Word8.toInt (codeVecGet (seg, !ptr)) val opc = (nb div 8) mod 8 in print (case opc of 0 => "test" | 3 => "neg " | 4 => "mul " | 5 => "imul" | 6 => "div " | 7 => "idiv" | _ => "???" ); print "\t"; printEA(rex, sizeFromRexW); (* Test has an immediate operand. It's 32-bits even in 64-bit mode. *) if opc = 0 then (print ","; print32 ()) else () end | 0wxff => (* Group5 *) let (* Opcode is determined by next byte. *) val nb = Word8.toInt (codeVecGet (seg, !ptr)) val opc = (nb div 8) mod 8 in print (case opc of 2 => "call" | 4 => "jmp " | 6 => "push" | _ => "???" ); print "\t"; printEA(rex, sz32_64) (* None of the cases we use need a prefix. *) end | _ => print(Word8.fmt StringCvt.HEX opByte); print "\n" end; (* end of while loop *) print "\n" end (* printCode *); (* Although this is used locally it must be defined at the top level otherwise a new RTS function will be compiler every time the containing function is called *) val sortFunction: (machineWord * word) array -> bool = RunCall.rtsCallFast1 "PolySortArrayOfAddresses" (* This actually does the final code-generation. *) fun generateCode {ops=operations, code=cvec as Code{procName, printAssemblyCode, printStream, profileObject, ...}, labelCount, resultClosure} : unit = let val (expanded, newLabelCount) = expandComplexOperations (operations, labelCount) val () = printLowLevelCode(expanded, cvec) local val initialBytesList = codeGenerate expanded in (* Fixup labels and shrink long branches to short. *) val (bytesList, codeSize) = fixupLabels(expanded, initialBytesList, newLabelCount) end local (* Extract the constants and the location of the references from the code. *) val (inlineConstants, addressConstants, nonAddressConstants) = getConstants(expanded, bytesList) (* Sort the non-address constants to remove duplicates. There don't seem to be many in practice. Since we're not actually interested in the order but only sorting to remove duplicates we can use a stripped-down Quicksort. *) fun sort([], out) = out | sort((addr, median) :: tl, out) = partition(median, tl, [addr], [], [], out) and partition(median, [], addrs, less, greater, out) = sort(less, sort(greater, (addrs, median) :: out)) | partition(median, (entry as (addr, value)) :: tl, addrs, less, greater, out) = if value = median then partition(median, tl, addr::addrs, less, greater, out) else if value < median then partition(median, tl, addrs, entry :: less, greater, out) else partition(median, tl, addrs, less, entry :: greater, out) (* Non-address constants. We can't use any ordering on them because a GC could change the values half way through the sort. Instead we use a simple search for a small number of constants and use an RTS call for larger numbers. We want to avoid quadratic cost when there are large numbers. *) val sortedConstants = if List.length addressConstants < 10 then let fun findDups([], out) = out | findDups((addr, value) :: tl, out) = let fun partition(e as (a, v), (eq, neq)) = if PolyML.pointerEq(value, v) then (a :: eq, neq) else (eq, e :: neq) val (eqAddr, neq) = List.foldl partition ([addr], []) tl in findDups(neq, (eqAddr, value) :: out) end in findDups(addressConstants, []) end else let fun swap (a, b) = (b, a) val arrayToSort: (machineWord * word) array = Array.fromList (List.map swap addressConstants) val _ = sortFunction arrayToSort fun makeList((v, a), []) = [([a], v)] | makeList((v, a), l as (aa, vv) :: tl) = if PolyML.pointerEq(v, vv) then (a :: aa, vv) :: tl else ([a], v) :: l in Array.foldl makeList [] arrayToSort end in val inlineConstants = inlineConstants and addressConstants = sortedConstants and nonAddressConstants = sort(nonAddressConstants, []) end (* Get the number of constants that need to be added to the address area. *) val constsInConstArea = List.length addressConstants local (* Add one byte for the HLT and round up to a number of words. *) val endOfCode = (codeSize+nativeWordSize) div nativeWordSize * (nativeWordSize div wordSize) val numOfNonAddrWords = Word.fromInt(List.length nonAddressConstants) (* Each entry in the non-address constant area is 8 bytes. *) val intSize = 0w8 div wordSize in val endOfByteArea = endOfCode + numOfNonAddrWords * intSize (* +4 for function name, register mask (no longer used), profile object and count of constants. *) val segSize = endOfByteArea + Word.fromInt constsInConstArea + 0w4 end (* Create a byte vector and copy the data in. This is a byte area and not scanned by the GC so cannot contain any addresses. *) val byteVec = byteVecMake segSize val ic = ref 0w0 local fun genByte (ival: Word8.word) = set8u (ival, !ic, byteVec) before ic := !ic + 0w1 in fun genBytes l = Word8Vector.app (fn i => genByte i) l val () = List.app (fn b => genBytes b) bytesList val () = genBytes(Word8Vector.fromList(opCodeBytes(HLT, NONE))) (* Marker - this is used by ScanConstants in the RTS. *) end (* Align ic onto a fullword boundary. *) val () = ic := ((!ic + nativeWordSize - 0w1) andb ~nativeWordSize) (* Copy the non-address constants. These are only used in 64-bit mode and are either real constants or integers that are too large to fit in a 32-bit inline constants. We don't use this for real constants in 32-bit mode because we don't have relative addressing. Instead a real constant is the inline address of a boxed real number. *) local fun putNonAddrConst(addrs, constant) = let val addrOfConst = ! ic val () = genBytes(Word8Vector.fromList(largeWordToBytes(constant, 8))) fun setAddr addr = set32s(Word.toLargeInt(addrOfConst - addr - 0w4), addr, byteVec) in List.app setAddr addrs end in val () = List.app putNonAddrConst nonAddressConstants end val _ = bytesToWords(! ic) = endOfByteArea orelse raise InternalError "mismatch" (* Put in the number of constants. This must go in before we actually put in any constants. In 32-bit mode there are only three constants: the function name and the register mask, now unused and the profile object. All other constants are in the code. *) local val addr = wordsToBytes(endOfByteArea + 0w3 + Word.fromInt constsInConstArea) fun setBytes(_, _, 0) = () | setBytes(ival, offset, count) = ( byteVecSet(byteVec, offset, Word8.fromLargeInt(ival mod 256)); setBytes(ival div 256, offset+0w1, count-1) ) in val () = setBytes(LargeInt.fromInt(3 + constsInConstArea), addr, Word.toInt wordSize) end; (* We've put in all the byte data so it is safe to convert this to a mutable code cell that can contain addresses and will be scanned by the GC. *) val codeSeg = byteVecToCodeVec(byteVec, resultClosure) (* Various RTS functions assume that the first constant is the function name. The profiler assumes that the third word is the address of the mutable that contains the profile count. The second word used to be used for the register mask but is no longer used. *) val () = codeVecPutWord (codeSeg, endOfByteArea, toMachineWord procName) val () = codeVecPutWord (codeSeg, endOfByteArea + 0w1, toMachineWord 1 (* No longer used. *)) (* Next the profile object. *) val () = codeVecPutWord (codeSeg, endOfByteArea + 0w2, profileObject) in let fun setBytes(_, _, 0w0) = () | setBytes(b, addr, count) = ( codeVecSet (codeSeg, addr, wordToWord8 b); setBytes(b >> 0w8, addr+0w1, count-0w1) ) (* Inline constants - native 32-bit only plus one special case in 32-in-64 *) fun putInlConst (addrs, SelfAddress) = (* Self address goes inline. *) codeVecPutConstant (codeSeg, addrs, toMachineWord(codeVecAddr codeSeg), ConstAbsolute) | putInlConst (addrs, InlineAbsoluteAddress m) = codeVecPutConstant (codeSeg, addrs, m, ConstAbsolute) | putInlConst (addrs, InlineRelativeAddress m) = codeVecPutConstant (codeSeg, addrs, m, ConstX86Relative) val _ = List.app putInlConst inlineConstants (* Address constants - native 64-bit and 32-in-64. *) fun putAddrConst ((addrs, m), constAddr) = (* Put the constant in the constant area and set the original address to be the relative offset to the constant itself. *) ( codeVecPutWord (codeSeg, constAddr, m); (* Put in the 32-bit offset - always unsigned since the destination is after the reference. *) List.app(fn addr => setBytes(constAddr * wordSize - addr - 0w4, addr, 0w4)) addrs; constAddr+0w1 ) (* Put the constants. Any values in the constant area start at +3 i.e. after the profile. *) val _ = List.foldl putAddrConst (endOfByteArea+0w3) addressConstants val () = if printAssemblyCode then (* print out the code *) ( printCode(cvec, codeSeg); printStream "\n\n" ) else () in (* Finally lock the code. *) codeVecLock(codeSeg, resultClosure) end (* the result *) end (* generateCode *) structure Sharing = struct type code = code and reg = reg and genReg = genReg and fpReg = fpReg and addrs = addrs and operation = operation and regSet = RegSet.regSet and label = label and branchOps = branchOps and arithOp = arithOp and shiftType = shiftType and repOps = repOps and fpOps = fpOps and fpUnaryOps = fpUnaryOps and sse2Operations = sse2Operations and opSize = opSize and closureRef = closureRef end end (* struct *) (* CODECONS *); diff --git a/mlsource/MLCompiler/DEBUGSIG.ML b/mlsource/MLCompiler/DEBUG.sig similarity index 96% rename from mlsource/MLCompiler/DEBUGSIG.ML rename to mlsource/MLCompiler/DEBUG.sig index e7fed89b..d0e6910d 100644 --- a/mlsource/MLCompiler/DEBUGSIG.ML +++ b/mlsource/MLCompiler/DEBUG.sig @@ -1,48 +1,48 @@ (* - Copyright (c) 2013-2016 David C.J. Matthews + Copyright (c) 2013-2016, 2020 David C.J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) (* Signature for debugging flags *) -signature DEBUGSIG = +signature DEBUG = sig val assemblyCodeTag : bool Universal.tag val bindingCounterTag : (unit -> FixedInt.int) Universal.tag val codetreeAfterOptTag : bool Universal.tag val codetreeTag : bool Universal.tag val createPrintFunctionsTag : bool Universal.tag val debugTag : bool Universal.tag val defaults : Universal.universal list val errorDepthTag : FixedInt.int Universal.tag val fileNameTag : string Universal.tag val getParameter : 'a Universal.tag -> Universal.universal list -> 'a val icodeTag : bool Universal.tag val inlineFunctorsTag : bool Universal.tag val lineLengthTag : FixedInt.int Universal.tag val lineNumberTag : (unit -> FixedInt.int) Universal.tag val lowlevelOptimiseTag : bool Universal.tag val maxInlineSizeTag : FixedInt.int Universal.tag val narrowOverloadFlexRecordTag : bool Universal.tag val offsetTag : (unit -> FixedInt.int) Universal.tag val parsetreeTag : bool Universal.tag val printDepthFunTag : (unit -> FixedInt.int) Universal.tag val profileAllocationTag : FixedInt.int Universal.tag val reportExhaustiveHandlersTag : bool Universal.tag val reportUnreferencedIdsTag : bool Universal.tag val reportDiscardedValuesTag: FixedInt.int Universal.tag val reportDiscardNone: FixedInt.int (* No reports *) and reportDiscardFunction: FixedInt.int (* Only report discarded functions *) and reportDiscardNonUnit: FixedInt.int (* Report discarding any non unit values *) end; diff --git a/mlsource/MLCompiler/DEBUGGER_.sml b/mlsource/MLCompiler/DEBUGGER_.sml index 56ac83ca..9ae69782 100644 --- a/mlsource/MLCompiler/DEBUGGER_.sml +++ b/mlsource/MLCompiler/DEBUGGER_.sml @@ -1,589 +1,589 @@ (* Title: Source level debugger for Poly/ML Author: David Matthews Copyright (c) David Matthews 2000, 2014, 2015, 2020 This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) functor DEBUGGER_ ( structure STRUCTVALS : STRUCTVALSIG structure VALUEOPS : VALUEOPSSIG structure CODETREE : CODETREESIG structure TYPETREE: TYPETREESIG structure ADDRESS : AddressSig structure COPIER: COPIERSIG structure TYPEIDCODE: TYPEIDCODESIG structure LEX : LEXSIG - structure DEBUG: DEBUGSIG + structure DEBUG: DEBUG structure UTILITIES : sig val splitString: string -> { first:string,second:string } end sharing STRUCTVALS.Sharing = VALUEOPS.Sharing = TYPETREE.Sharing = COPIER.Sharing = TYPEIDCODE.Sharing = CODETREE.Sharing = ADDRESS = LEX.Sharing ) : DEBUGGER = struct open STRUCTVALS VALUEOPS CODETREE COPIER TYPETREE DEBUG (* The static environment contains these kinds of entries. *) datatype environEntry = EnvValue of string * types * locationProp list | EnvException of string * types * locationProp list | EnvVConstr of string * types * bool * int * locationProp list | EnvTypeid of { original: typeId, freeId: typeId } | EnvStructure of string * signatures * locationProp list | EnvTConstr of string * typeConstrSet | EnvStartFunction of string * location * types | EnvEndFunction of string * location * types local open ADDRESS in (* Entries in the thread data. The RTS allocates enough space for this. The first entry is 5 because earlier entries are used by Thread.Thread. *) val threadIdStack = mkConst(toMachineWord 0w5) (* The static/dynamic/location entries for calling fns *) and threadIdCurrentStatic = mkConst(toMachineWord 0w6) (* The static info for bindings i.e. name/type. *) and threadIdCurrentDynamic = mkConst(toMachineWord 0w7) (* Dynamic infor for bindings i.e. actual run-time value. *) and threadIdCurrentLocation = mkConst(toMachineWord 0w8) (* Location in code: line number/offset etc. *) (* Global function entries. These could be in storage allocated by the RTS. *) (* Specialised option type here. Because a function is always boxed this avoids the need for an extra level of indirection. *) datatype ('a, 'b) functionOpt = NoFunction | AFunction of 'a -> 'b val globalOnEntry = ref NoFunction and globalOnExit = ref NoFunction and globalOnExitExc = ref NoFunction and globalOnBreakPoint = ref NoFunction val onEntryCode = mkLoadOperation(LoadStoreMLWord{isImmutable=false}, mkConst(toMachineWord globalOnEntry), CodeZero) and onExitCode = mkLoadOperation(LoadStoreMLWord{isImmutable=false}, mkConst(toMachineWord globalOnExit), CodeZero) and onExitExcCode = mkLoadOperation(LoadStoreMLWord{isImmutable=false}, mkConst(toMachineWord globalOnExitExc), CodeZero) and onBreakPointCode = mkLoadOperation(LoadStoreMLWord{isImmutable=false}, mkConst(toMachineWord globalOnBreakPoint), CodeZero) (* We need to ensure that any break-point code preserves the state. It could be modified if we hit a break-point and run the interactive debugger with PolyML.Compiler.debug true. *) fun wrap (f:'a -> unit) (x: 'a) : unit = let val threadId: address = RunCall.unsafeCast(Thread.Thread.self()) val stack = loadWord(threadId, 0w5) and static = loadWord(threadId, 0w6) and dynamic = loadWord(threadId, 0w7) and location = loadWord(threadId, 0w8) fun restore () = ( assignWord(threadId, 0w5, stack); assignWord(threadId, 0w6, static); assignWord(threadId, 0w7, dynamic); assignWord(threadId, 0w8, location) ) in f x handle exn => (restore(); PolyML.Exception.reraise exn); restore() end fun setOnEntry NONE = globalOnEntry := NoFunction | setOnEntry (SOME(f: string * PolyML.location -> unit)) = globalOnEntry := AFunction (wrap f) and setOnExit NONE = globalOnExit := NoFunction | setOnExit (SOME(f: string * PolyML.location -> unit)) = globalOnExit := AFunction (wrap f) and setOnExitException NONE = globalOnExitExc := NoFunction | setOnExitException (SOME(f: string * PolyML.location -> exn -> unit)) = globalOnExitExc := AFunction (fn x => wrap (f x)) and setOnBreakPoint NONE = globalOnBreakPoint := NoFunction | setOnBreakPoint (SOME(f: PolyML.location * bool ref -> unit)) = globalOnBreakPoint := AFunction (wrap f) end (* When stopped at a break-point any Bound ids must be replaced by Free ids. We make new Free ids at this point. *) fun envTypeId (id as TypeId{ description, idKind = Bound{arity, ...}, ...}) = EnvTypeid { original = id, freeId = makeFreeId(arity, Global CodeZero, isEquality id, description) } | envTypeId id = EnvTypeid { original = id, freeId = id } fun searchEnvs match (staticEntry :: statics, dlist as dynamicEntry :: dynamics) = ( case (match (staticEntry, dynamicEntry), staticEntry) of (SOME result, _) => SOME result | (NONE, EnvTypeid _) => searchEnvs match (statics, dynamics) | (NONE, EnvVConstr _) => searchEnvs match (statics, dynamics) | (NONE, EnvValue _) => searchEnvs match (statics, dynamics) | (NONE, EnvException _) => searchEnvs match (statics, dynamics) | (NONE, EnvStructure _) => searchEnvs match (statics, dynamics) | (NONE, EnvStartFunction _) => searchEnvs match (statics, dynamics) | (NONE, EnvEndFunction _) => searchEnvs match (statics, dynamics) (* EnvTConstr doesn't have an entry in the dynamic list *) | (NONE, EnvTConstr _) => searchEnvs match (statics, dlist) ) | searchEnvs _ _ = NONE (* N.B. It is possible to have ([EnvTConstr ...], []) in the arguments so we can't treat that if either the static or dynamic list is nil and the other non-nil as an error. *) (* Exported functions that appear in PolyML.DebuggerInterface. *) type debugState = environEntry list * machineWord list * location fun searchType ((clist, rlist, _): debugState) typeid = let fun match (EnvTypeid{original, freeId }, valu) = if sameTypeId(original, typeid) then case freeId of TypeId{description, idKind as Free _, ...} => (* This can occur for datatypes inside functions. *) SOME(TypeId { access= Global(mkConst valu), idKind=idKind, description=description}) | _ => raise Misc.InternalError "searchType: TypeFunction" else NONE | match _ = NONE in case (searchEnvs match (clist, rlist), typeid) of (SOME t, _) => t | (NONE, TypeId{description, idKind = TypeFn typeFn, ...}) => makeTypeFunction(description, typeFn) | (NONE, typeid as TypeId{description, idKind = Bound{arity, ...}, ...}) => (* The type ID is missing. Make a new temporary ID. *) makeFreeId(arity, Global(TYPEIDCODE.codeForUniqueId()), isEquality typeid, description) | (NONE, typeid as TypeId{description, idKind = Free{arity, ...}, ...}) => (* The type ID is missing. Make a new temporary ID. *) makeFreeId(arity, Global(TYPEIDCODE.codeForUniqueId()), isEquality typeid, description) end (* Values must be copied so that compile-time type IDs are replaced by their run-time values. *) fun makeTypeConstr (state: debugState) (TypeConstrSet(tcons, (*tcConstructors*) _)) = let val typeID = searchType state (tcIdentifier tcons) val newTypeCons = makeTypeConstructor(tcName tcons, tcTypeVars tcons, typeID, tcLocations tcons) val newValConstrs = (*map copyAConstructor tcConstructors*) [] in TypeConstrSet(newTypeCons, newValConstrs) end (* When creating a structure we have to add a type map that will look up the bound Ids. *) fun makeStructure state (name, rSig, locations, valu) = let local val Signatures{ name = sigName, tab, typeIdMap, firstBoundIndex, locations=sigLocs, ... } = rSig fun getFreeId n = searchType state (makeBoundId(0 (* ??? *), Global CodeZero, n, false, false, basisDescription "")) in val newSig = makeSignature(sigName, tab, firstBoundIndex, sigLocs, composeMaps(typeIdMap, getFreeId), []) end in makeGlobalStruct (name, newSig, mkConst valu, locations) end local fun runTimeType (state: debugState) ty = let fun copyId(TypeId{idKind=Free _, access=Global _ , ...}) = NONE (* Use original *) | copyId id = SOME(searchType state id) in copyType (ty, fn x => x, fn tcon => copyTypeConstr (tcon, copyId, fn x => x, fn s => s)) end (* Return the value as a constant. In almost all cases we just return the value. The exception is when we have an equality type variable. In that case we must return a function because we will use applyToInstanceType to apply it to the instance type(s). N.B. This is probably because of the way that allowGeneralisation side-effects the type variables resulting in local type variables becoming generic. *) fun getValue(valu, ty) = let val filterTypeVars = List.filter (fn tv => not TYPEIDCODE.justForEqualityTypes orelse tvEquality tv) val polyVars = filterTypeVars (getPolyTypeVars(ty, fn _ => NONE)) val nPolyVars = List.length polyVars in if nPolyVars = 0 then mkConst valu else mkInlproc(mkConst valu, nPolyVars, "poly", [], 0) end in fun makeValue state (name, ty, location, valu) = mkGvar(name, runTimeType state ty, getValue(valu, ty), location) and makeException state (name, ty, location, valu) = mkGex(name, runTimeType state ty, getValue(valu, ty), location) and makeConstructor state (name, ty, nullary, count, location, valu) = makeValueConstr(name, runTimeType state ty, nullary, count, Global(getValue(valu, ty)), location) and makeAnonymousValue state (ty, valu) = makeValue state ("", ty, [], valu) end (* Functions to make the debug entries. These are needed both in CODEGEN_PARSETREE for the core language and STRUCTURES for the module language. *) (* Debugger status within the compiler. During compilation the environment is built up as a pair consisting of the static data and code to compute the run-time data. The static data, a constant at run-time, holds the variable names and types. The run-time code, when executed at run-time, returns the address of a list holding the actual values of the variables. "dynEnv" is always a "load" from a (codetree) variable. It has type level->codetree rather than codetree because the next reference could be inside an inner function. "lastLoc" is the last location that was *) type debuggerStatus = {staticEnv: environEntry list, dynEnv: level->codetree, lastLoc: location} val initialDebuggerStatus: debuggerStatus = {staticEnv = [], dynEnv = fn _ => CodeZero, lastLoc = LEX.nullLocation } (* Set the current state in the thread data. *) fun updateState (level, mkAddr) (decs, debugEnv: debuggerStatus as {staticEnv, dynEnv, ...}) = let open ADDRESS val threadId = multipleUses(getCurrentThreadId, fn () => mkAddr 1, level) fun assignItem(offset, value) = mkNullDec(mkStoreOperation(LoadStoreMLWord{isImmutable=false}, #load threadId level, offset, value)) val newDecs = decs @ #dec threadId @ [assignItem(threadIdCurrentStatic, mkConst(toMachineWord staticEnv)), assignItem(threadIdCurrentDynamic, dynEnv level)] in (newDecs, debugEnv) end fun makeValDebugEntries (vars: values list, debugEnv: debuggerStatus, level, lex, mkAddr, typeVarMap) = if getParameter debugTag (LEX.debugParams lex) then let fun loadVar (var, (decs, {staticEnv, dynEnv, lastLoc, ...})) = let val loadVal = codeVal (var, level, typeVarMap, [], lex, LEX.nullLocation) val newEnv = (* Create a new entry in the environment. *) mkDatatype [ loadVal (* Value. *), dynEnv level ] val { dec, load } = multipleUses (newEnv, fn () => mkAddr 1, level) val ctEntry = case var of Value{class=Exception, name, typeOf, locations, ...} => EnvException(name, typeOf, locations) | Value{class=Constructor{nullary, ofConstrs, ...}, name, typeOf, locations, ...} => EnvVConstr(name, typeOf, nullary, ofConstrs, locations) | Value{name, typeOf, locations, ...} => EnvValue(name, typeOf, locations) in (decs @ dec, {staticEnv = ctEntry :: staticEnv, dynEnv = load, lastLoc = lastLoc}) end in updateState (level, mkAddr) (List.foldl loadVar ([], debugEnv) vars) end else ([], debugEnv) fun makeTypeConstrDebugEntries(typeCons, debugEnv, level, lex, mkAddr) = if not (getParameter debugTag (LEX.debugParams lex)) then ([], debugEnv) else let fun foldIds(tc :: tcs, {staticEnv, dynEnv, lastLoc, ...}) = let val cons = tsConstr tc val id = tcIdentifier cons val {second = typeName, ...} = UTILITIES.splitString(tcName cons) in if tcIsAbbreviation (tsConstr tc) then foldIds(tcs, {staticEnv=EnvTConstr(typeName, tc) :: staticEnv, dynEnv=dynEnv, lastLoc = lastLoc}) else let (* This code will build a cons cell containing the run-time value associated with the type Id as the hd and the rest of the run-time environment as the tl. *) val loadTypeId = TYPEIDCODE.codeId(id, level) val newEnv = mkDatatype [ loadTypeId, dynEnv level ] val { dec, load } = multipleUses (newEnv, fn () => mkAddr 1, level) (* Make an entry for the type constructor itself as well as the new type id. The type Id is used both for the type constructor and also for any values of the type. *) val (decs, newEnv) = foldIds(tcs, {staticEnv=EnvTConstr(typeName, tc) :: envTypeId id :: staticEnv, dynEnv=load, lastLoc = lastLoc}) in (dec @ decs, newEnv) end end | foldIds([], debugEnv) = ([], debugEnv) in updateState (level, mkAddr) (foldIds(typeCons, debugEnv)) end fun makeStructDebugEntries (strs: structVals list, debugEnv, level, lex, mkAddr) = if getParameter debugTag (LEX.debugParams lex) then let fun loadStruct (str as Struct { name, signat, locations, ...}, (decs, {staticEnv, dynEnv, lastLoc, ...})) = let val loadStruct = codeStruct (str, level) val newEnv = mkDatatype [ loadStruct (* Structure. *), dynEnv level ] val { dec, load } = multipleUses (newEnv, fn () => mkAddr 1, level) val ctEntry = EnvStructure(name, signat, locations) in (decs @ dec, {staticEnv=ctEntry :: staticEnv, dynEnv=load, lastLoc = lastLoc}) end in updateState (level, mkAddr) (List.foldl loadStruct ([], debugEnv) strs) end else ([], debugEnv) (* Create debug entries for typeIDs. The idea is that if we stop in the debugger we can access the type ID, particularly for printing values of the type. "envTypeId" creates a free id for each bound id but the print and equality functions are extracted when we are stopped in the debugger. *) fun makeTypeIdDebugEntries(typeIds, debugEnv, level, lex, mkAddr) = if not (getParameter debugTag (LEX.debugParams lex)) then ([], debugEnv) else let fun foldIds(id :: ids, {staticEnv, dynEnv, lastLoc, ...}) = let (* This code will build a cons cell containing the run-time value associated with the type Id as the hd and the rest of the run-time environment as the tl. *) val loadTypeId = case id of TypeId { access = Formal addr, ... } => (* If we are processing functor arguments we will have a Formal here. *) mkInd(addr, mkLoadArgument 0) | _ => TYPEIDCODE.codeId(id, level) val newEnv = mkDatatype [ loadTypeId, dynEnv level ] val { dec, load } = multipleUses (newEnv, fn () => mkAddr 1, level) val (decs, newEnv) = foldIds(ids, {staticEnv=envTypeId id :: staticEnv, dynEnv=load, lastLoc = lastLoc}) in (dec @ decs, newEnv) end | foldIds([], debugEnv) = ([], debugEnv) in updateState (level, mkAddr) (foldIds(typeIds, debugEnv)) end (* Update the location info in the thread data if we want debugging info. If the location has not changed don't do anything. Whether it has changed could depend on whether we're only counting line numbers or whether we have more precise location info with the IDE. *) fun updateDebugLocation(debuggerStatus as {staticEnv, dynEnv, lastLoc, ...}, location, lex) = if not (getParameter debugTag (LEX.debugParams lex)) orelse lastLoc = location then ([], debuggerStatus) else let open ADDRESS val setLocation = mkStoreOperation(LoadStoreMLWord{isImmutable=false}, getCurrentThreadId, threadIdCurrentLocation, mkConst(toMachineWord location)) in ([mkNullDec setLocation], {staticEnv=staticEnv, dynEnv=dynEnv, lastLoc=location}) end (* Add debugging calls on entry and exit to a function. *) fun wrapFunctionInDebug(codeBody: debuggerStatus -> codetree, name: string, argCode, argType, resType: types, location, entryEnv: debuggerStatus, level, lex, mkAddr) = if not (getParameter debugTag (LEX.debugParams lex)) then codeBody entryEnv (* Code-generate the body without any wrapping. *) else let open ADDRESS val functionName = name (* TODO: munge this to get the root. *) fun addStartExitEntry({staticEnv, dynEnv, lastLoc, ...}, code, ty, startExit) = let val newEnv = mkDatatype [ code, dynEnv level ] val { dec, load } = multipleUses (newEnv, fn () => mkAddr 1, level) val ctEntry = startExit(functionName, location, ty) in (dec, {staticEnv=ctEntry :: staticEnv, dynEnv=load, lastLoc = lastLoc}) end (* All the "on" functions take this as an argument. *) val onArgs = [mkConst(toMachineWord(functionName, location))] val threadId = multipleUses(getCurrentThreadId, fn () => mkAddr 1, level) fun loadIdEntry offset = multipleUses(mkLoadOperation(LoadStoreMLWord{isImmutable=false}, #load threadId level, offset), fn () => mkAddr 1, level) val currStatic = loadIdEntry threadIdCurrentStatic and currDynamic = loadIdEntry threadIdCurrentDynamic and currLocation = loadIdEntry threadIdCurrentLocation and currStack = loadIdEntry threadIdStack (* At the start of the function: 1. Push the previous state to the stack. 2. Create a debugging entry for the arguments 3. Update the state to the state on entry, including the args 4. Call the global onEntry function if it's set 5. Call the local onEntry function if it's set *) (* Save the previous state. *) val assignStack = mkStoreOperation(LoadStoreMLWord{isImmutable=false}, #load threadId level, threadIdStack, mkDatatype[ #load currStatic level, #load currDynamic level, #load currLocation level, #load currStack level]) val prefixCode = #dec threadId @ #dec currStatic @ #dec currDynamic @ #dec currLocation @ #dec currStack @ [mkNullDec assignStack] (* Make a debugging entry for the arguments. This needs to be set before we call onEntry so we can produce tracing info. It also needs to be passed to the body of the function so that it is included in the debug status of the rest of the body. *) local val {staticEnv, dynEnv, lastLoc, ...} = entryEnv val newEnv = mkDatatype [ argCode, dynEnv level ] val { dec, load } = multipleUses (newEnv, fn () => mkAddr 1, level) val ctEntry = EnvStartFunction(functionName, location, argType) in val debuggerDecs = dec val bodyDebugEnv = {staticEnv = ctEntry :: staticEnv, dynEnv = load, lastLoc = lastLoc} end local val {staticEnv, dynEnv, ...} = bodyDebugEnv val assignStatic = mkStoreOperation(LoadStoreMLWord{isImmutable=false}, #load threadId level, threadIdCurrentStatic, mkConst(toMachineWord staticEnv)) val assignDynamic = mkStoreOperation(LoadStoreMLWord{isImmutable=false}, #load threadId level, threadIdCurrentDynamic, dynEnv level) val assignLocation = mkStoreOperation(LoadStoreMLWord{isImmutable=false}, #load threadId level, threadIdCurrentLocation, mkConst(toMachineWord location)) val onEntryFn = multipleUses(onEntryCode, fn () => mkAddr 1, level) val optCallOnEntry = mkIf(mkTagTest(#load onEntryFn level, 0w0, 0w0), CodeZero, mkEval(#load onEntryFn level, onArgs)) in val entryCode = debuggerDecs @ [mkNullDec assignStatic, mkNullDec assignDynamic, mkNullDec assignLocation] @ #dec onEntryFn @ [mkNullDec optCallOnEntry] end (* Restore the state. Used both if the function returns normally or if it raises an exception. We use the old state rather than popping the stack because that is more reliable if we have an asynchronous exception. *) local (* Set the entry in the thread vector to an entry from the top-of-stack. *) fun restoreEntry(offset, value) = mkNullDec( mkStoreOperation(LoadStoreMLWord{isImmutable=false}, #load threadId level, offset, value)) in val restoreState = [restoreEntry(threadIdCurrentStatic, #load currStatic level), restoreEntry(threadIdCurrentDynamic, #load currDynamic level), restoreEntry(threadIdCurrentLocation, #load currLocation level), restoreEntry(threadIdStack, #load currStack level)] end local (* If an exception is raised we need to call the onExitException entry, restore the state and reraise the exception. *) (* There are potential race conditions here if we have asynchronous exceptions. *) val exPacketAddr = mkAddr 1 val onExitExcFn = multipleUses(onExitExcCode, fn () => mkAddr 1, level) (* OnExitException has an extra curried argument - the exception packet. *) val optCallOnExitExc = mkIf(mkTagTest(#load onExitExcFn level, 0w0, 0w0), CodeZero, mkEval(mkEval(#load onExitExcFn level, onArgs), [mkLoadLocal exPacketAddr])) in val exPacketAddr = exPacketAddr val exceptionCase = mkEnv(#dec onExitExcFn @ [mkNullDec optCallOnExitExc] @ restoreState, mkRaise(mkLoadLocal exPacketAddr)) end (* Code for the body and the exception. *) val bodyCode = multipleUses(mkHandle(codeBody bodyDebugEnv, exceptionCase, exPacketAddr), fn () => mkAddr 1, level) (* Code for normal exit. *) local val endFn = addStartExitEntry(entryEnv, #load bodyCode level, resType, EnvEndFunction) val (rtEnvDec, _) = updateState (level, mkAddr) endFn val onExitFn = multipleUses(onExitCode, fn () => mkAddr 1, level) val optCallOnExit = mkIf(mkTagTest(#load onExitFn level, 0w0, 0w0), CodeZero, mkEval(#load onExitFn level, onArgs)) in val exitCode = rtEnvDec @ #dec onExitFn @ [mkNullDec optCallOnExit] end in mkEnv(prefixCode @ entryCode @ #dec bodyCode @ exitCode @ restoreState, #load bodyCode level) end type breakPoint = bool ref (* Create a local break point and check the global and local break points. *) fun breakPointCode(breakPoint, location, level, lex, mkAddr) = if not (getParameter debugTag (LEX.debugParams lex)) then [] else let open ADDRESS (* Create a new local breakpoint and assign it to the ref. It is possible for the ref to be already assigned a local breakpoint value if we are compiling a match. In that case the same expression may be code-generated more than once but we only want one local break-point. *) val localBreakPoint = case breakPoint of ref (SOME bpt) => bpt | r as ref NONE => let val b = ref false in r := SOME b; b end; (* Call the breakpoint function if it's defined. *) val globalBpt = multipleUses(onBreakPointCode, fn () => mkAddr 1, level) val testCode = mkIf( mkNot(mkTagTest(#load globalBpt level, 0w0, 0w0)), mkEval(#load globalBpt level, [mkTuple[mkConst(toMachineWord location), mkConst(toMachineWord localBreakPoint)]]), CodeZero ) in #dec globalBpt @ [mkNullDec testCode] end structure Sharing = struct type types = types type values = values type machineWord = machineWord type fixStatus = fixStatus type structVals = structVals type typeConstrSet = typeConstrSet type signatures = signatures type functors = functors type locationProp = locationProp type environEntry = environEntry type typeId = typeId type level = level type lexan = lexan type codeBinding = codeBinding type codetree = codetree type typeVarMap = typeVarMap type debuggerStatus = debuggerStatus end end; diff --git a/mlsource/MLCompiler/Debug.ML b/mlsource/MLCompiler/Debug.ML index 18354f8b..e844de8e 100644 --- a/mlsource/MLCompiler/Debug.ML +++ b/mlsource/MLCompiler/Debug.ML @@ -1,127 +1,127 @@ (* Copyright (c) 2000 Cambridge University Technical Services Limited - Modified David C.J. Matthews 2008, 2013, 2015-16. + Modified David C.J. Matthews 2008, 2013, 2015-16, 2020. This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation;. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) -structure Debug: DEBUGSIG = +structure Debug: DEBUG = struct local open Universal in (* Get the current line number. *) val lineNumberTag: (unit->FixedInt.int) tag = tag() (* Get the current offset (position on line or in file). *) val offsetTag: (unit->FixedInt.int) tag = tag() (* File name. *) val fileNameTag: string tag = tag() (* Binding counter *) val bindingCounterTag: (unit->FixedInt.int) tag = tag() (* How much to print in error messages? default 6 *) val errorDepthTag: FixedInt.int tag = tag() (* Control print depth in PolyML.print. *) val printDepthFunTag: (unit->FixedInt.int) tag = tag() (* Length of line in PolyML.print. error messages etc. *) val lineLengthTag: FixedInt.int tag = tag() (* Compile in debugging code? default false *) val debugTag: bool tag = tag() (* Compilation fine tuning. *) (* Should functors be made inline? default true. *) val inlineFunctorsTag: bool tag = tag() (* Control how big functions should be before they're not inlined. *) val maxInlineSizeTag: FixedInt.int tag = tag() (* Add profile information to each allocation? default zero. At the moment this is effectively a bool but having an int allows for the possibility of recording different information. *) val profileAllocationTag: FixedInt.int tag = tag() (* Compiler debugging. *) (* Print parsetree after parsing? default false *) val parsetreeTag: bool tag = tag() (* Print codetree after compiling? default false *) val codetreeTag: bool tag = tag() (* Print the optimised code after compiling? default false *) val codetreeAfterOptTag: bool tag = tag() (* Print x86 intermediate code in code-generator? default false *) val icodeTag: bool tag = tag() (* Switch on/off low-level optimisation. *) val lowlevelOptimiseTag: bool tag = tag() (* Print assembly code in code-generator? default false *) val assemblyCodeTag: bool tag = tag() (* Report unreferenced identifiers as warnings *) val reportUnreferencedIdsTag: bool tag = tag() (* Report catch-all handlers as warnings *) val reportExhaustiveHandlersTag: bool tag = tag() (* Use a narrow context to resolve overloading and flexible records. *) val narrowOverloadFlexRecordTag: bool tag = tag() (* Create print functions for datatypes based on the constructors. *) val createPrintFunctionsTag: bool tag = tag() (* Warning level for discarding values *) val reportDiscardedValuesTag: FixedInt.int tag = tag() val reportDiscardNone = 0: FixedInt.int (* No reports *) and reportDiscardFunction = 1: FixedInt.int (* Only report discarded functions *) and reportDiscardNonUnit = 2: FixedInt.int (* Report discarding any non unit values *) (* To avoid circularity of dependencies a few tags are defined elsewhere: *) (* ValueOps.printSpaceTag: ValueOps.nameSpace tag Pretty.printOutputTag: (pretty->unit) tag Pretty.compilerOutputTag: (pretty->unit) tag Lex.errorMessageProcTag: (pretty * bool * FixedInt.int -> unit) tag ExportTreeString.rootTreeTag: (unit -> exportTree) tag *) val defaults = [ tagInject lineNumberTag (fn () => 0), (* Zero line number *) tagInject offsetTag (fn () => 0), (* Zero offset *) tagInject fileNameTag "", tagInject bindingCounterTag (fn () => 0), (* Zero counter *) tagInject inlineFunctorsTag true, tagInject maxInlineSizeTag 80, tagInject profileAllocationTag 0, tagInject parsetreeTag false, tagInject codetreeTag false, tagInject icodeTag false, tagInject lowlevelOptimiseTag true, tagInject assemblyCodeTag false, tagInject codetreeAfterOptTag false, tagInject errorDepthTag 6, tagInject printDepthFunTag (fn () => 0), tagInject lineLengthTag 77, tagInject debugTag false, tagInject reportUnreferencedIdsTag false, tagInject reportExhaustiveHandlersTag false, tagInject narrowOverloadFlexRecordTag false, tagInject createPrintFunctionsTag true, tagInject reportDiscardedValuesTag reportDiscardFunction ] fun getParameter (t:'a tag) (tagList: universal list) :'a = case List.find (tagIs t) tagList of SOME a => tagProject t a | NONE => (* Use the default *) ( case List.find (tagIs t) defaults of SOME a => tagProject t a | NONE => raise Misc.InternalError "tag missing" ) end end; diff --git a/mlsource/MLCompiler/INITIALISE_.ML b/mlsource/MLCompiler/INITIALISE_.ML index 34560872..f05728f5 100644 --- a/mlsource/MLCompiler/INITIALISE_.ML +++ b/mlsource/MLCompiler/INITIALISE_.ML @@ -1,2065 +1,2065 @@ (* Copyright (c) 2000 Cambridge University Technical Services Limited Updated David C.J. Matthews 2008-9, 2012, 2013, 2015-20 This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) (* Title: Initialise ML Global Declarations. Author: Dave Matthews,Cambridge University Computer Laboratory Copyright Cambridge University 1985 *) functor INITIALISE_ ( structure LEX: LEXSIG structure TYPETREE : TYPETREESIG structure STRUCTVALS : STRUCTVALSIG structure VALUEOPS : VALUEOPSSIG structure CODETREE : CODETREESIG structure EXPORTTREE: EXPORTTREESIG structure DATATYPEREP: DATATYPEREPSIG structure TYPEIDCODE: TYPEIDCODESIG structure MAKE: MAKESIG structure ADDRESS : AddressSig - structure DEBUG: DEBUGSIG + structure DEBUG: DEBUG structure DEBUGGER : DEBUGGER structure PRETTY : PRETTYSIG structure PRINTTABLE: PRINTTABLESIG structure MISC : sig val unescapeString : string -> string exception Conversion of string; (* string to int conversion failure *) end structure VERSION: sig val compilerVersion: string val versionNumber: int end structure UNIVERSALTABLE: sig type universal = Universal.universal type univTable type 'a tag = 'a Universal.tag val univLookup: univTable * 'a tag * string -> 'a option val fold: (string * universal * 'a -> 'a) -> 'a -> univTable -> 'a end sharing STRUCTVALS.Sharing = VALUEOPS.Sharing = TYPETREE.Sharing = EXPORTTREE.Sharing = PRETTY.Sharing = CODETREE.Sharing = MAKE.Sharing = ADDRESS = DATATYPEREP.Sharing = TYPEIDCODE.Sharing = DEBUGGER.Sharing = LEX.Sharing = PRINTTABLE.Sharing sharing STRUCTVALS.Sharing = VALUEOPS.Sharing = TYPETREE.Sharing = EXPORTTREE.Sharing = PRETTY.Sharing = CODETREE.Sharing = MAKE.Sharing = ADDRESS = DATATYPEREP.Sharing = TYPEIDCODE.Sharing = DEBUGGER.Sharing = LEX.Sharing = PRINTTABLE.Sharing = UNIVERSALTABLE ) : sig type gEnv val initGlobalEnv : {globalTable : gEnv, intIsArbitraryPrecision: bool } -> unit end = struct open STRUCTVALS; open TYPETREE open VALUEOPS; open CODETREE; open ADDRESS; open MAKE; open MISC; open EXPORTTREE open DATATYPEREP val intInfType = mkTypeConstruction ("int", intInfConstr, [], []) and realType = mkTypeConstruction ("real", realConstr, [], []) and charType = mkTypeConstruction ("char", charConstr, [], []) and wordType = mkTypeConstruction ("word", wordConstr, [], []) val declInBasis = [DeclaredAt inBasis] fun applyList _ [] = () | applyList f (h :: t) = (f h : unit; applyList f t); fun initGlobalEnv{globalTable : gEnv, intIsArbitraryPrecision: bool } = let val Env globalEnv = MAKE.gEnvAsEnv globalTable val enterGlobalValue = #enterVal globalEnv; val enterGlobalType = #enterType globalEnv; (* Some routines to help make the types. *) local (* careful - STRUCTVALS.intType differs from TYPETREE.intType *) open TYPETREE; in (* Make some type variables *) fun makeEqTV () = mkTypeVar (generalisable, true, false, false) fun makeTV () = mkTypeVar (generalisable, false, false, false) fun makePrintTV() = mkTypeVar (generalisable, false, false, true) fun makeTypeVariable() = makeTv {value=emptyType, level=generalisable, equality=false, nonunifiable=false, printable=false} (* Make some functions *) infixr 5 ->> fun a ->> b = mkFunctionType (a, b); infix 7 **; fun a ** b = mkProductType [a, b]; (* Type identifiers for the types of the declarations. *) val Int = if intIsArbitraryPrecision then intInfType else fixedIntType val String = stringType; val Bool = boolType; val Unit = unitType; val Char = charType; val Word = wordType; val Real = realType val Exn = exnType val mkTypeConstruction = mkTypeConstruction; val () = setPreferredInt(if intIsArbitraryPrecision then intInfConstr else fixedIntConstr) end; fun makePolymorphic(tvs, c) = let open TYPEIDCODE val tvs = List.filter(fn TypeVar tv => not justForEqualityTypes orelse tvEquality tv | _ => false) tvs in if null tvs then c else mkInlproc(c, List.length tvs, "", [], 0) end (* Function to make a type identifier with a pretty printer that just prints "?". None of the types are equality types so the equality function is empty. *) local fun monotypePrinter _ = PRETTY.PrettyString "?" in fun defaultEqAndPrintCode () = let open TypeValue val code = createTypeValue{ eqCode = CodeZero, printCode = mkConst (toMachineWord (ref monotypePrinter)), boxedCode = boxedNever, sizeCode = singleWord } in Global (genCode(code, [], 0) ()) end end fun makeTypeAbbreviation(name, fullName, typeVars, typeResult, locations) = makeTypeConstructor( name, typeVars, makeTypeFunction(basisDescription fullName, (typeVars, typeResult)), locations) (* Make an opaque type and add it to an environment. *) fun makeAndDeclareOpaqueType(typeName, fullName, env) = let val typeconstr = makeTypeConstructor(typeName, [], makeFreeId(0, defaultEqAndPrintCode(), false, basisDescription fullName), declInBasis); in #enterType env (typeName, TypeConstrSet(typeconstr, [])); mkTypeConstruction (typeName, typeconstr, [], declInBasis) end; (* List of something *) fun List (base : types) : types = mkTypeConstruction ("list", tsConstr listConstr, [base], declInBasis); (* ref something *) fun Ref (base : types) : types = mkTypeConstruction ("ref", refConstr, [base], declInBasis); fun Option (base : types) : types = mkTypeConstruction ("option", tsConstr optionConstr, [base], declInBasis); (* Type-dependent functions. *) fun mkSpecialFun (name:string, typeof:types, opn: typeDependent) : values = makeOverloaded (name, typeof, opn); (* Overloaded functions. *) fun mkOverloaded (name:string) (typeof: types) : values = mkSpecialFun(name, typeof, TypeDep) (* Make a structure. Returns the table as an environment so that entries can be added to the structure. *) fun makeStructure(parentEnv, name) = let val str as Struct{signat=Signatures{tab, ...}, ...} = makeEmptyGlobal name val () = #enterStruct parentEnv (name, str) val Env env = makeEnv tab in env end val () = enterGlobalType ("unit", TypeConstrSet(unitConstr, [])); local val falseCons = mkGconstr ("false", Bool, createNullaryConstructor(EnumForm{tag=0w0, maxTag=0w1}, [], "false"), true, 2, declInBasis) val trueCons = mkGconstr ("true", Bool, createNullaryConstructor(EnumForm{tag=0w1, maxTag=0w1}, [], "true"), true, 2, declInBasis) val boolEnv = makeStructure(globalEnv, "Bool") (* Bool structure *) val notFn = mkGvar("not", Bool ->> Bool, mkUnaryFn BuiltIns.NotBoolean, declInBasis) in val () = #enterType boolEnv ("bool", TypeConstrSet(boolConstr, [trueCons, falseCons])) val () = #enterVal boolEnv ("true", trueCons) val () = #enterVal boolEnv ("false", falseCons) val () = #enterVal boolEnv ("not", notFn) end; val () = enterGlobalType ("int", TypeConstrSet(if intIsArbitraryPrecision then intInfConstr else fixedIntConstr, [])) val () = enterGlobalType ("char", TypeConstrSet(charConstr, [])) val () = enterGlobalType ("string", TypeConstrSet(stringConstr, [])) val () = enterGlobalType ("real", TypeConstrSet(realConstr, [])) val () = (* Enter :: and nil. *) List.app(fn(tv as Value{name, ...}) => enterGlobalValue(name, tv)) (tsConstructors listConstr) val () = enterGlobalType ("list", listConstr); val () = (* Enter NONE and SOME. *) List.app(fn(tv as Value{name, ...}) => enterGlobalValue(name, tv)) (tsConstructors optionConstr) val () = enterGlobalType ("option", optionConstr); local val refCons = let val a = mkTypeVar(generalisable, false, false, false) in mkGconstr ("ref", a ->> Ref a, createUnaryConstructor(RefForm, [a], "ref"), false, 1, declInBasis) end in val () = enterGlobalType ("ref", TypeConstrSet(refConstr, [refCons])); val () = enterGlobalValue ("ref", refCons); end local open BuiltIns fun monoTypePrinter _ = PRETTY.PrettyString "?" val idCode = let open TypeValue val equalLongWordFn = mkInlproc( mkBinary(LargeWordComparison TestEqual, mkLoadArgument 0, mkLoadArgument 1), 2, "EqualLargeWord()", [], 0) val code = createTypeValue{ eqCode=equalLongWordFn, printCode=mkConst (toMachineWord (ref monoTypePrinter)), boxedCode = boxedNever, sizeCode = singleWord } in Global (genCode(code, [], 0) ()) end in val largeWordType = makeTypeConstructor("word", [], makeFreeId(0, idCode, true, basisDescription "LargeWord.word"), declInBasis) val LargeWord = mkTypeConstruction ("LargeWord.word", largeWordType, [], declInBasis) end val () = enterGlobalType ("exn", TypeConstrSet(exnConstr, [])); val () = enterGlobalType ("word", TypeConstrSet(wordConstr, [])); val runCallEnv = makeStructure(globalEnv, "RunCall") fun enterRunCall (name : string, entry : codetree, typ : types) : unit = let val value = mkGvar (name, typ, entry, declInBasis); in #enterVal runCallEnv (name, value) end local (* unsafeCast. Can be used to convert any value to any type. *) val a = makeTV () val b = makeTV () val unsafeCastEntry = mkInlproc (mkLoadArgument 0 (* just the parameter *), 1, "unsafeCast(1)", [], 0) in val () = enterRunCall ("unsafeCast", makePolymorphic([a, b], unsafeCastEntry), a ->> b) end local val a = makeTV() and b = makeTV() open BuiltIns in (* isShort - test if a value is tagged rather than being an address. *) val () = enterRunCall ("isShort", makePolymorphic([a], mkUnaryFn IsTaggedValue), a ->> Bool) (* pointer equality *) val () = enterRunCall ("pointerEq", makePolymorphic([a], mkBinaryFn PointerEq), a ** a ->> Bool) (* load a word. The index is in words and is always zero or positive. *) val () = enterRunCall ("loadWord", makePolymorphic([a, b], mkLoadOperationFn(LoadStoreMLWord{isImmutable=false})), a ** Word ->> b) (* Load a word from an immutable. *) val () = enterRunCall ("loadWordFromImmutable", makePolymorphic([a, b], mkLoadOperationFn(LoadStoreMLWord{isImmutable=true})), a ** Word ->> b) (* load a byte. The index is in bytes and is always zero or positive. Probably the result should be a Word8.word value or a char. *) val () = enterRunCall ("loadByte", makePolymorphic([a, b], mkLoadOperationFn(LoadStoreMLByte{isImmutable=false})), a ** Word ->> b) (* Load a byte from an immutable. *) val () = enterRunCall ("loadByteFromImmutable", makePolymorphic([a, b], mkLoadOperationFn(LoadStoreMLByte{isImmutable=true})), a ** Word ->> b) (* Get the length of a heap cell. *) val () = enterRunCall ("memoryCellLength", makePolymorphic([a], mkUnaryFn MemoryCellLength), a ->> Word) (* Return the flags. Perhaps this could return a Word8.word value instead of a word. *) val () = enterRunCall ("memoryCellFlags", makePolymorphic([a], mkUnaryFn MemoryCellFlags), a ->> Word) (* Return the number of bytes per word. This is a constant since we have separate pre-built compilers for 32-bit and 64-bit. N.B. The byte order is not a constant since we only have a single pre-built compiler for little-endian and big-endian interpreted code. *) val () = enterRunCall ("bytesPerWord", mkConst(toMachineWord wordSize), Word) (* Store a word *) val () = enterRunCall ("storeWord", makePolymorphic([a, b], mkStoreOperationFn(LoadStoreMLWord{isImmutable=false})), mkProductType[a, Word, b] ->> Unit) (* Store a byte *) val () = enterRunCall ("storeByte", makePolymorphic([a, b], mkStoreOperationFn(LoadStoreMLByte{isImmutable=false})), mkProductType[a, Word, b] ->> Unit) (* Lock a mutable cell. *) val () = enterRunCall ("clearMutableBit", makePolymorphic([a], mkUnaryFn ClearMutableFlag), a ->> Unit) (* Allocate a byte cell. The second argument is the flags byte. It might be better if this were a Word8.word value. *) val () = enterRunCall ("allocateByteMemory", makePolymorphic([a], mkBinaryFn AllocateByteMemory), Word ** Word ->> a) (* Allocate a word cell. *) val () = enterRunCall ("allocateWordMemory", makePolymorphic([a, b], mkAllocateWordMemoryFn), mkProductType[Word, Word, a] ->> b) (* Byte vector operations. *) val () = enterRunCall ("byteVectorEqual", makePolymorphic([a], mkBlockOperationFn BlockOpEqualByte), mkProductType[a, a, Word, Word, Word] ->> Bool) val () = enterRunCall ("byteVectorCompare", makePolymorphic([a], mkBlockOperationFn BlockOpCompareByte), mkProductType[a, a, Word, Word, Word] ->> Int) (* Block moves. *) val () = enterRunCall ("moveBytes", makePolymorphic([a], mkBlockOperationFn (BlockOpMove{isByteMove=true})), mkProductType[a, a, Word, Word, Word] ->> Unit) val () = enterRunCall ("moveWords", makePolymorphic([a], mkBlockOperationFn (BlockOpMove{isByteMove=false})), mkProductType[a, a, Word, Word, Word] ->> Unit) (* Untagged loads and stores. *) val () = enterRunCall ("loadUntagged", mkLoadOperationFn LoadStoreUntaggedUnsigned, String ** Word ->> Word) val () = enterRunCall ("storeUntagged", mkStoreOperationFn LoadStoreUntaggedUnsigned, mkProductType[String, Word, Word] ->> Unit) val () = enterRunCall ("touch", makePolymorphic([a], mkUnaryFn TouchAddress), a ->> Unit) end local val debugOpts = [] (* Place to add debugging if necessary. *) (* [tagInject Pretty.compilerOutputTag (Pretty.prettyPrint(print, 70)), tagInject assemblyCodeTag true] *) fun makeCall rtsCall n entryName = rtsCall (entryName, n, debugOpts) val makeFastCall = makeCall CODETREE.Foreign.rtsCallFast (* We need to wrap this so that the arguments are passed in registers. *) fun makeRunCallTupled (argTypes, resultType, callN) : codetree = let val width = List.length argTypes val name = "rtsCall" ^ Int.toString width; local val f = mkLoadClosure 0 (* first item from enclosing scope *) val tuple = mkLoadArgument 0 (* the inner parameter *) val args = case argTypes of [singleType] => [(tuple, singleType)] | argTypes => let val argVals = List.tabulate(width, fn n => mkInd (n, tuple)) in ListPair.zipEq(argVals, argTypes) end in val innerBody = mkCall (f, args, resultType) end local (* The closure contains the address of the RTS call. *) val f = mkEval(mkConst callN, [mkLoadArgument 0]) val innerLambda = mkInlproc (innerBody, 1, name ^ "(1)", [mkLoadLocal 0], 0) in val outerBody = mkEnv([mkDec (0, f)], innerLambda) end val outerLambda = mkInlproc (outerBody, 1, name, [], 1) in outerLambda end (* "Full" calls pass the thread Id as the first parameter. *) fun makeRunCallTupledFull (argTypes, resultType) = let val width = List.length argTypes val callN = toMachineWord(makeFastCall(width + 1)) val name = "rtsCall" ^ Int.toString width; local val f = mkLoadClosure 0 (* first item from enclosing scope *) val tuple = mkLoadArgument 0 (* the inner parameter *) val args = case argTypes of [singleType] => [(tuple, singleType)] | argTypes => let val argVals = List.tabulate(width, fn n => mkInd (n, tuple)) in ListPair.zipEq(argVals, argTypes) end in val innerBody = mkEnv( [ mkDec(0, mkCall (f, (getCurrentThreadId, GeneralType) :: args, resultType)), mkNullDec checkRTSException ], mkLoadLocal 0) end local (* The closure contains the address of the RTS call. *) val f = mkEval(mkConst callN, [mkLoadArgument 0]) (* This creates the actual call. *) val innerLambda = mkInlproc (innerBody, 1, name ^ "(1)", [mkLoadLocal 0], 1) in val outerBody = mkEnv([mkDec (0, f)], innerLambda) end val outerLambda = mkInlproc (outerBody, 1, name, [], 1) in outerLambda end local val a = makeTV () and b = makeTV () fun makeInlCode(makeCall, name) = let val call1 = toMachineWord(makeCall 1) val body = mkEval(mkConst call1, [mkLoadArgument 0]) val proc = mkInlproc (body, 1, name, [], 0) in makePolymorphic([a, b], proc) end in val rtsCallFast1Entry = makeInlCode(makeFastCall, "rtsCallFast1") end local val a = makeTV () and b = makeTV () and c = makeTV () and d = makeTV () and e = makeTV () and f = makeTV () fun makeRtsCall(n, makeCall) = makeRunCallTupled(List.tabulate(n, fn _ => GeneralType), GeneralType, toMachineWord(makeCall n)) fun makeFullRtsCall n = makeRunCallTupledFull(List.tabulate(n, fn _ => GeneralType), GeneralType) in val rtsCallFull0Entry = makePolymorphic([a], makeFullRtsCall 0) and rtsCallFast0Entry = makePolymorphic([a], makeRtsCall(0, makeFastCall)) val rtsCall0Type = String ->> Unit ->> a val rtsCall1Type = String ->> a ->> b val rtsCallFull1Entry = makePolymorphic([a, b], makeFullRtsCall 1) val rtsCallFull2Entry = makePolymorphic([a, b, c], makeFullRtsCall 2) and rtsCallFast2Entry = makePolymorphic([a, b, c], makeRtsCall(2, makeFastCall)) val rtsCall2Type = String ->> TYPETREE.mkProductType [a,b] ->> c val rtsCallFull3Entry = makePolymorphic([a, b, c, d], makeFullRtsCall 3) val rtsCallFast3Entry = makePolymorphic([a, b, c, d], makeRtsCall(3, makeFastCall)) val rtsCall3Type = String ->> TYPETREE.mkProductType [a,b,c] ->> d val rtsCallFull4Entry = makePolymorphic([a, b, c, d, e], makeFullRtsCall 4) val rtsCallFast4Entry = makePolymorphic([a, b, c, d, e], makeRtsCall(4, makeFastCall)) val rtsCall4Type = String ->> TYPETREE.mkProductType [a,b,c,d] ->> e val rtsCallFull5Entry = makePolymorphic([a, b, c, d, e, f], makeFullRtsCall 5) val rtsCall5Type = String ->> TYPETREE.mkProductType [a,b,c,d,e] ->> f end in val () = enterRunCall ("rtsCallFull0", rtsCallFull0Entry, rtsCall0Type) val () = enterRunCall ("rtsCallFast0", rtsCallFast0Entry, rtsCall0Type) val () = enterRunCall ("rtsCallFull1", rtsCallFull1Entry, rtsCall1Type) val () = enterRunCall ("rtsCallFast1", rtsCallFast1Entry, rtsCall1Type) val () = enterRunCall ("rtsCallFull2", rtsCallFull2Entry, rtsCall2Type) val () = enterRunCall ("rtsCallFast2", rtsCallFast2Entry, rtsCall2Type) val () = enterRunCall ("rtsCallFull3", rtsCallFull3Entry, rtsCall3Type) val () = enterRunCall ("rtsCallFast3", rtsCallFast3Entry, rtsCall3Type) val () = enterRunCall ("rtsCallFast4", rtsCallFast4Entry, rtsCall4Type) val () = enterRunCall ("rtsCallFull4", rtsCallFull4Entry, rtsCall4Type) val () = enterRunCall ("rtsCallFull5", rtsCallFull5Entry, rtsCall5Type) val makeRunCallTupled = makeRunCallTupled (* Needed for reals. *) end local (* Create nullary exception. *) fun makeException0(name, id) = let val exc = Value{ name = name, typeOf = TYPETREE.exnType, access = Global(mkConst(toMachineWord id)), class = Exception, locations = declInBasis, references = NONE, instanceTypes=NONE } in #enterVal runCallEnv (name, exc) end (* Create exception with parameter. *) and makeException1(name, id, exType) = let val exc = Value{ name = name, typeOf = exType ->> TYPETREE.exnType, access = Global(mkConst(toMachineWord id)), class = Exception, locations = declInBasis, references = NONE, instanceTypes=NONE } in #enterVal runCallEnv (name, exc) end (* Exception numbers. Most of these are hard-coded in the RTS. *) val EXC_interrupt = 1 val EXC_syserr = 2 val EXC_size = 4 val EXC_overflow = 5 val EXC_divide = 7 val EXC_conversion = 8 val EXC_XWindows = 10 val EXC_subscript = 11 val EXC_thread = 12 val EXC_Bind = 100 (* In Match compiler. *) val EXC_Match = 101 val EXC_Fail = 103 in val () = List.app makeException0 [ ("Interrupt", EXC_interrupt), ("Size", EXC_size), ("Bind", EXC_Bind), ("Div", EXC_divide), ("Match", EXC_Match), ("Overflow", EXC_overflow), ("Subscript", EXC_subscript) ] val () = List.app makeException1 [ ("Fail", EXC_Fail, String), ("Conversion", EXC_conversion, String), ("XWindows", EXC_XWindows, String), ("Thread", EXC_thread, String), ("SysErr", EXC_syserr, String ** Option LargeWord) ] end (* Standard Basis structures for basic types. These contain the definitions of the basic types and operations on them. The structures are extended in the basis library and overloaded functions are extracted from them. *) local val largeIntEnv = makeStructure(globalEnv, "LargeInt") (* The comparison operations take two arbitrary precision ints and a general "compare" function that returns a fixed precision int. *) val compareType = mkProductType[intInfType, intInfType, intInfType ** intInfType ->> fixedIntType] ->> Bool val arithType = mkProductType[intInfType, intInfType, intInfType ** intInfType ->> intInfType] ->> intInfType fun enterArbitrary(name, oper, typ) = let val value = mkGvar (name, typ, mkArbitraryFn oper, declInBasis) in #enterVal largeIntEnv (name, value) end in val () = #enterType largeIntEnv ("int", TypeConstrSet(intInfConstr, [])) (* These functions are used internally. *) val () = enterArbitrary("less", ArbCompare BuiltIns.TestLess, compareType) val () = enterArbitrary("greater", ArbCompare BuiltIns.TestGreater, compareType) val () = enterArbitrary("lessEq", ArbCompare BuiltIns.TestLessEqual, compareType) val () = enterArbitrary("greaterEq", ArbCompare BuiltIns.TestGreaterEqual, compareType) val () = enterArbitrary("add", ArbArith BuiltIns.ArithAdd, arithType) val () = enterArbitrary("subtract", ArbArith BuiltIns.ArithSub, arithType) val () = enterArbitrary("multiply", ArbArith BuiltIns.ArithMult, arithType) end local val fixedIntEnv = makeStructure(globalEnv, "FixedInt") open BuiltIns fun enterBinary(name, oper, typ) = let val value = mkGvar (name, typ, mkBinaryFn oper, declInBasis) in #enterVal fixedIntEnv (name, value) end val compareType = fixedIntType ** fixedIntType ->> Bool and binaryType = fixedIntType ** fixedIntType ->> fixedIntType fun enterComparison(name, test) = enterBinary(name, WordComparison{test=test, isSigned=true}, compareType) and enterBinaryOp(name, oper) = enterBinary(name, FixedPrecisionArith oper, binaryType) in val () = #enterType fixedIntEnv ("int", TypeConstrSet(fixedIntConstr, [])) val () = enterComparison("<", TestLess) val () = enterComparison("<=", TestLessEqual) val () = enterComparison(">", TestGreater) val () = enterComparison(">=", TestGreaterEqual) val () = enterBinaryOp("+", ArithAdd) val () = enterBinaryOp("-", ArithSub) val () = enterBinaryOp("*", ArithMult) val () = enterBinaryOp("quot", ArithQuot) val () = enterBinaryOp("rem", ArithRem) end local open BuiltIns val largeWordEnv = makeStructure(globalEnv, "LargeWord") fun enterBinary(name, oper, typ) = let val value = mkGvar (name, typ, mkBinaryFn oper, declInBasis) in #enterVal largeWordEnv (name, value) end val compareType = LargeWord ** LargeWord ->> Bool and binaryType = LargeWord ** LargeWord ->> LargeWord and shiftType = LargeWord ** Word ->> LargeWord (* The shift amount is a Word. *) fun enterComparison(name, test) = enterBinary(name, LargeWordComparison test, compareType) and enterBinaryOp(name, oper) = enterBinary(name, LargeWordArith oper, binaryType) and enterBinaryLogical(name, oper) = enterBinary(name, LargeWordLogical oper, binaryType) and enterBinaryShift(name, oper) = enterBinary(name, LargeWordShift oper, shiftType) in val () = #enterType largeWordEnv ("word", TypeConstrSet(largeWordType, [])) val () = enterComparison("<", TestLess) val () = enterComparison("<=", TestLessEqual) val () = enterComparison(">", TestGreater) val () = enterComparison(">=", TestGreaterEqual) val () = enterBinaryOp("+", ArithAdd) val () = enterBinaryOp("-", ArithSub) val () = enterBinaryOp("*", ArithMult) val () = enterBinaryOp("div", ArithDiv) val () = enterBinaryOp("mod", ArithMod) val () = enterBinaryLogical("orb", LogicalOr) val () = enterBinaryLogical("andb", LogicalAnd) val () = enterBinaryLogical("xorb", LogicalXor) val () = enterBinaryShift("<<", ShiftLeft) val () = enterBinaryShift(">>", ShiftRightLogical) val () = enterBinaryShift("~>>", ShiftRightArithmetic) val LargeWord = LargeWord end local val wordStructEnv = makeStructure(globalEnv, "Word") open BuiltIns fun enterBinary(name, oper, typ) = let val value = mkGvar (name, typ, mkBinaryFn oper, declInBasis) in #enterVal wordStructEnv (name, value) end val compareType = Word ** Word ->> Bool and binaryType = Word ** Word ->> Word fun enterComparison(name, test) = enterBinary(name, WordComparison{test=test, isSigned=false}, compareType) and enterBinaryOp(name, oper) = enterBinary(name, WordArith oper, binaryType) and enterBinaryLogical(name, oper) = enterBinary(name, WordLogical oper, binaryType) and enterBinaryShift(name, oper) = enterBinary(name, WordShift oper, binaryType) val toLargeWordFn = mkGvar ("toLargeWord", Word ->> LargeWord, mkUnaryFn UnsignedToLongWord, declInBasis) and toLargeWordXFn = mkGvar ("toLargeWordX", Word ->> LargeWord, mkUnaryFn SignedToLongWord, declInBasis) and fromLargeWordFn = mkGvar ("fromLargeWord", LargeWord ->> Word, mkUnaryFn LongWordToTagged, declInBasis) in val () = #enterType wordStructEnv ("word", TypeConstrSet(wordConstr, [])) val () = enterComparison("<", TestLess) val () = enterComparison("<=", TestLessEqual) val () = enterComparison(">", TestGreater) val () = enterComparison(">=", TestGreaterEqual) val () = enterBinaryOp("+", ArithAdd) val () = enterBinaryOp("-", ArithSub) val () = enterBinaryOp("*", ArithMult) val () = enterBinaryOp("div", ArithDiv) val () = enterBinaryOp("mod", ArithMod) val () = enterBinaryLogical("orb", LogicalOr) val () = enterBinaryLogical("andb", LogicalAnd) val () = enterBinaryLogical("xorb", LogicalXor) val () = enterBinaryShift("<<", ShiftLeft) val () = enterBinaryShift(">>", ShiftRightLogical) val () = enterBinaryShift("~>>", ShiftRightArithmetic) val () = #enterVal wordStructEnv ("toLargeWord", toLargeWordFn) val () = #enterVal wordStructEnv ("toLargeWordX", toLargeWordXFn) val () = #enterVal wordStructEnv ("fromLargeWord", fromLargeWordFn) end local val charEnv = makeStructure(globalEnv, "Char") open BuiltIns (* Comparison functions are the same as Word. *) fun enterComparison(name, test) = let val typ = Char ** Char ->> Bool val entry = mkBinaryFn(WordComparison{test=test, isSigned=false}) val value = mkGvar (name, typ, entry, declInBasis) in #enterVal charEnv (name, value) end in val () = #enterType charEnv ("char", TypeConstrSet(charConstr, [])) val () = enterComparison("<", TestLess) val () = enterComparison("<=", TestLessEqual) val () = enterComparison(">", TestGreater) val () = enterComparison(">=", TestGreaterEqual) end local val stringEnv = makeStructure(globalEnv, "String") in val () = #enterType stringEnv ("string", TypeConstrSet(stringConstr, [])) end local val realEnv = makeStructure(globalEnv, "Real") (* These are only used in Real so are included here rather than in RunCall. rtsCallFastRealtoReal is used for functions such as sqrt. rtsCallFastGeneraltoReal is used for Real.fromLargeInt. *) val debugOpts = [] (* Place to add debugging if necessary. *) fun makeFastRealRealCall entryName = CODETREE.Foreign.rtsCallFastRealtoReal (entryName, debugOpts) and makeFastRealRealRealCall entryName = CODETREE.Foreign.rtsCallFastRealRealtoReal (entryName, debugOpts) and makeFastIntInfRealCall entryName = CODETREE.Foreign.rtsCallFastGeneraltoReal (entryName, debugOpts) and makeFastRealGeneralRealCall entryName = CODETREE.Foreign.rtsCallFastRealGeneraltoReal (entryName, debugOpts) val rtsCallFastR_REntry = makeRunCallTupled([DoubleFloatType], DoubleFloatType, toMachineWord makeFastRealRealCall) (* This needs to be tupled. *) val rtsCallFastRR_REntry = makeRunCallTupled([DoubleFloatType, DoubleFloatType], DoubleFloatType, toMachineWord makeFastRealRealRealCall) and rtsCallFastRI_REntry = makeRunCallTupled([DoubleFloatType, GeneralType], DoubleFloatType, toMachineWord makeFastRealGeneralRealCall) val rtsCallFastI_REntry = makeRunCallTupled([GeneralType], DoubleFloatType, toMachineWord makeFastIntInfRealCall) val rtsCallFastF_F = mkGvar ("rtsCallFastR_R", String ->> Real ->> Real, rtsCallFastR_REntry, declInBasis) val rtsCallFastFF_F = mkGvar ("rtsCallFastRR_R", String ->> Real ** Real ->> Real, rtsCallFastRR_REntry, declInBasis) val rtsCallFastFG_F = mkGvar ("rtsCallFastRI_R", String ->> Real ** Int ->> Real, rtsCallFastRI_REntry, declInBasis) val rtsCallFastG_F = mkGvar ("rtsCallFastI_R", String ->> intInfType ->> Real, rtsCallFastI_REntry, declInBasis) fun enterUnary(name, oper, typ) = let val value = mkGvar (name, typ, mkUnaryFn oper, declInBasis) in #enterVal realEnv (name, value) end fun enterBinary(name, oper, typ) = let val value = mkGvar (name, typ, mkBinaryFn oper, declInBasis) in #enterVal realEnv (name, value) end val compareType = Real ** Real ->> Bool and binaryType = Real ** Real ->> Real and unaryType = Real ->> Real and realToFixType = Real ->> fixedIntType open BuiltIns IEEEReal fun enterComparison(name, test) = enterBinary(name, RealComparison(test, PrecDouble), compareType) and enterBinaryOp(name, oper) = enterBinary(name, RealArith(oper, PrecDouble), binaryType) in val () = #enterType realEnv ("real", TypeConstrSet(realConstr, [])) val () = #enterVal realEnv ("rtsCallFastR_R", rtsCallFastF_F) val () = #enterVal realEnv ("rtsCallFastRR_R", rtsCallFastFF_F) val () = #enterVal realEnv ("rtsCallFastRI_R", rtsCallFastFG_F) val () = #enterVal realEnv ("rtsCallFastI_R", rtsCallFastG_F) val () = enterComparison("<", TestLess) val () = enterComparison("<=", TestLessEqual) val () = enterComparison(">", TestGreater) val () = enterComparison(">=", TestGreaterEqual) val () = enterComparison("==", TestEqual) (* real is not an eqtype. *) (* Included unordered mainly because it's easy to implement isNan. *) val () = enterComparison("unordered", TestUnordered) val () = enterBinaryOp("+", ArithAdd) val () = enterBinaryOp("-", ArithSub) val () = enterBinaryOp("*", ArithMult) val () = enterBinaryOp("/", ArithDiv) val () = enterUnary("~", RealNeg PrecDouble, unaryType) val () = enterUnary("abs", RealAbs PrecDouble, unaryType) val () = enterUnary("fromFixedInt", RealFixedInt PrecDouble, fixedIntType ->> Real) val () = enterUnary("truncFix", RealToInt(PrecDouble, TO_ZERO), realToFixType) val () = enterUnary("roundFix", RealToInt(PrecDouble, TO_NEAREST), realToFixType) val () = enterUnary("ceilFix", RealToInt(PrecDouble, TO_POSINF), realToFixType) val () = enterUnary("floorFix", RealToInt(PrecDouble, TO_NEGINF), realToFixType) end local val real32Env = makeStructure(globalEnv, "Real32") val floatType = mkTypeConstruction ("real", floatConstr, [], []) val Float = floatType val debugOpts = [] (* Place to add debugging if necessary. *) fun makeFastFloatFloatCall entryName = CODETREE.Foreign.rtsCallFastFloattoFloat (entryName, debugOpts) and makeFastFloatFloatFloatCall entryName = CODETREE.Foreign.rtsCallFastFloatFloattoFloat (entryName, debugOpts) and makeFastIntInfFloatCall entryName = CODETREE.Foreign.rtsCallFastGeneraltoFloat (entryName, debugOpts) and makeFastFloatGeneralFloatCall entryName = CODETREE.Foreign.rtsCallFastFloatGeneraltoFloat (entryName, debugOpts) val rtsCallFastR_REntry = makeRunCallTupled([SingleFloatType], SingleFloatType, toMachineWord makeFastFloatFloatCall) (* This needs to be tupled. *) val rtsCallFastRR_REntry = makeRunCallTupled([SingleFloatType, SingleFloatType], SingleFloatType, toMachineWord makeFastFloatFloatFloatCall) and rtsCallFastRI_REntry = makeRunCallTupled([SingleFloatType, GeneralType], SingleFloatType, toMachineWord makeFastFloatGeneralFloatCall) val rtsCallFastI_REntry = makeRunCallTupled([GeneralType], SingleFloatType, toMachineWord makeFastIntInfFloatCall) val rtsCallFastF_F = mkGvar ("rtsCallFastF_F", String ->> Float ->> Float, rtsCallFastR_REntry, declInBasis) val rtsCallFastFF_F = mkGvar ("rtsCallFastFF_F", String ->> Float ** Float ->> Float, rtsCallFastRR_REntry, declInBasis) val rtsCallFastFG_F = mkGvar ("rtsCallFastFI_F", String ->> Float ** Int ->> Float, rtsCallFastRI_REntry, declInBasis) val rtsCallFastG_F = mkGvar ("rtsCallFastI_F", String ->> intInfType ->> Float, rtsCallFastI_REntry, declInBasis) fun enterUnary(name, oper, typ) = let val value = mkGvar (name, typ, mkUnaryFn oper, declInBasis) in #enterVal real32Env (name, value) end fun enterBinary(name, oper, typ) = let val value = mkGvar (name, typ, mkBinaryFn oper, declInBasis) in #enterVal real32Env (name, value) end val compareType = Float ** Float ->> Bool and binaryType = Float ** Float ->> Float and unaryType = Float ->> Float and floatToFixType = Float ->> fixedIntType open BuiltIns IEEEReal fun enterComparison(name, test) = enterBinary(name, RealComparison(test, PrecSingle), compareType) and enterBinaryOp(name, oper) = enterBinary(name, RealArith(oper, PrecSingle), binaryType) in val () = #enterType real32Env ("real", TypeConstrSet(floatConstr, [])) val () = enterUnary("toLarge", BuiltIns.FloatToDouble, floatType ->> Real) (* Conversion with the current rounding mode. *) and () = enterUnary("fromReal", BuiltIns.DoubleToFloat NONE, Real ->> floatType) (* There are various versions of this function for each of the rounding modes. *) and () = enterUnary("fromRealRound", BuiltIns.DoubleToFloat (SOME IEEEReal.TO_NEAREST), Real ->> floatType) and () = enterUnary("fromRealTrunc", BuiltIns.DoubleToFloat (SOME IEEEReal.TO_ZERO), Real ->> floatType) and () = enterUnary("fromRealCeil", BuiltIns.DoubleToFloat (SOME IEEEReal.TO_POSINF), Real ->> floatType) and () = enterUnary("fromRealFloor", BuiltIns.DoubleToFloat (SOME IEEEReal.TO_NEGINF), Real ->> floatType) val () = #enterVal real32Env ("rtsCallFastR_R", rtsCallFastF_F) val () = #enterVal real32Env ("rtsCallFastRR_R", rtsCallFastFF_F) val () = #enterVal real32Env ("rtsCallFastRI_R", rtsCallFastFG_F) val () = #enterVal real32Env ("rtsCallFastI_R", rtsCallFastG_F) val () = enterComparison("<", TestLess) val () = enterComparison("<=", TestLessEqual) val () = enterComparison(">", TestGreater) val () = enterComparison(">=", TestGreaterEqual) val () = enterComparison("==", TestEqual) (* Real32.real is not an eqtype. *) val () = enterComparison("unordered", TestUnordered) val () = enterBinaryOp("+", ArithAdd) val () = enterBinaryOp("-", ArithSub) val () = enterBinaryOp("*", ArithMult) val () = enterBinaryOp("/", ArithDiv) val () = enterUnary("~", RealNeg PrecSingle, unaryType) val () = enterUnary("abs", RealAbs PrecSingle, unaryType) val () = enterUnary("truncFix", RealToInt(PrecSingle, TO_ZERO), floatToFixType) val () = enterUnary("roundFix", RealToInt(PrecSingle, TO_NEAREST), floatToFixType) val () = enterUnary("ceilFix", RealToInt(PrecSingle, TO_POSINF), floatToFixType) val () = enterUnary("floorFix", RealToInt(PrecSingle, TO_NEGINF), floatToFixType) end val bootstrapEnv = makeStructure(globalEnv, "Bootstrap") fun enterBootstrap (name : string, entry : codetree, typ : types) : unit = let val value = mkGvar (name, typ, entry, declInBasis) in #enterVal bootstrapEnv (name, value) end local val threadEnv = makeStructure(globalEnv, "Thread") open TypeValue fun monoTypePrinter _ = PRETTY.PrettyString "?" val code = createTypeValue{ eqCode=equalPointerOrWordFn, printCode=mkConst (toMachineWord (ref monoTypePrinter)), boxedCode=boxedAlways, sizeCode=singleWord } (* Thread.thread type. This is an equality type with pointer equality. *) val threadConstr= makeTypeConstructor ( "thread", [], makeFreeId(0, Global (genCode(code, [], 0) ()), true, basisDescription "thread"), [DeclaredAt inBasis]) val threadType = mkTypeConstruction ("thread", threadConstr, [], []); val selfFunction = mkGvar ("self", Unit ->> threadType, getCurrentThreadIdFn, declInBasis) val atIncrFunction = mkGvar("atomicIncr", Ref Word ->> Word, mkUnaryFn BuiltIns.AtomicIncrement, declInBasis) val atDecrFunction = mkGvar("atomicDecr", Ref Word ->> Word, mkUnaryFn BuiltIns.AtomicDecrement, declInBasis) val atResetFunction = mkGvar("atomicReset", Ref Word ->> Unit, mkUnaryFn BuiltIns.AtomicReset, declInBasis) in val () = #enterType threadEnv ("thread", TypeConstrSet(threadConstr, [])) val () = #enterVal threadEnv ("self", selfFunction) val () = #enterVal threadEnv ("atomicIncr", atIncrFunction) val () = #enterVal threadEnv ("atomicDecr", atDecrFunction) val () = #enterVal threadEnv ("atomicReset", atResetFunction) end local val fmemEnv = makeStructure(globalEnv, "ForeignMemory") val a = makeTV() (* We don't have Word8.word or Word32.word at this point so the easiest way to deal with this is to make them polymorphic. *) val get8Function = mkGvar("get8", LargeWord ** Word ->> a, makePolymorphic([a], mkLoadOperationFn LoadStoreC8), declInBasis) val get16Function = mkGvar("get16", LargeWord ** Word ->> Word, mkLoadOperationFn LoadStoreC16, declInBasis) val get32Function = mkGvar("get32", LargeWord ** Word ->> a, makePolymorphic([a], mkLoadOperationFn LoadStoreC32), declInBasis) val get64Function = mkGvar("get64", LargeWord ** Word ->> LargeWord, mkLoadOperationFn LoadStoreC64, declInBasis) val getFloatFunction = mkGvar("getFloat", LargeWord ** Word ->> Real, mkLoadOperationFn LoadStoreCFloat, declInBasis) val getDoubleFunction = mkGvar("getDouble", LargeWord ** Word ->> Real, mkLoadOperationFn LoadStoreCDouble, declInBasis) val set8Function = mkGvar("set8", mkProductType[LargeWord, Word, a] ->> Unit, makePolymorphic([a], mkStoreOperationFn LoadStoreC8), declInBasis) val set16Function = mkGvar("set16", mkProductType[LargeWord, Word, Word] ->> Unit, mkStoreOperationFn LoadStoreC16, declInBasis) val set32Function = mkGvar("set32", mkProductType[LargeWord, Word, a] ->> Unit, makePolymorphic([a], mkStoreOperationFn LoadStoreC32), declInBasis) val set64Function = mkGvar("set64", mkProductType[LargeWord, Word, LargeWord] ->> Unit, mkStoreOperationFn LoadStoreC64, declInBasis) val setFloatFunction = mkGvar("setFloat", mkProductType[LargeWord, Word, Real] ->> Unit, mkStoreOperationFn LoadStoreCFloat, declInBasis) val setDoubleFunction = mkGvar("setDouble", mkProductType[LargeWord, Word, Real] ->> Unit, mkStoreOperationFn LoadStoreCDouble, declInBasis) val allocCStackFn = mkGvar("allocCStack", Word ->> LargeWord, mkUnaryFn BuiltIns.AllocCStack, declInBasis) val freeCStackFn = mkGvar("freeCStack", LargeWord ** Word ->> Unit, mkBinaryFn BuiltIns.FreeCStack, declInBasis) in val () = #enterVal fmemEnv ("get8", get8Function) val () = #enterVal fmemEnv ("get16", get16Function) val () = #enterVal fmemEnv ("get32", get32Function) val () = #enterVal fmemEnv ("get64", get64Function) val () = #enterVal fmemEnv ("getFloat", getFloatFunction) val () = #enterVal fmemEnv ("getDouble", getDoubleFunction) val () = #enterVal fmemEnv ("set8", set8Function) val () = #enterVal fmemEnv ("set16", set16Function) val () = #enterVal fmemEnv ("set32", set32Function) val () = #enterVal fmemEnv ("set64", set64Function) val () = #enterVal fmemEnv ("setFloat", setFloatFunction) val () = #enterVal fmemEnv ("setDouble", setDoubleFunction) val () = #enterVal fmemEnv ("allocCStack", allocCStackFn) (* Free is a binary operation that takes both the allocated address and the size. The size is used by the compiled code where this is implemented using the C-stack. The allocated address is intended for possible use by the interpreter where so that it can be implemented as malloc/free. *) val () = #enterVal fmemEnv ("freeCStack", freeCStackFn) end local val foreignEnv = makeStructure(globalEnv, "Foreign") local val EXC_foreign = 23 val foreignException = Value{ name = "Foreign", typeOf = String ->> TYPETREE.exnType, access = Global(mkConst(toMachineWord EXC_foreign)), class = Exception, locations = declInBasis, references = NONE, instanceTypes=NONE } in val () = #enterVal foreignEnv ("Foreign", foreignException) end val arg0 = mkLoadArgument 0 val arg1 = mkLoadArgument 1 local val callForeignCall = mkEval(mkConst (toMachineWord CODETREE.Foreign.foreignCall), [arg0]) val innerBody = mkEval(mkLoadClosure 0, [mkInd(0, arg0), mkInd(1, arg0), mkInd(2, arg0)]) val outerBody = mkEnv([mkDec(0, callForeignCall)], mkInlproc(innerBody, 1, "foreignCall(1)(1)", [mkLoadLocal 0], 0)) in val foreignCallEntry = mkInlproc(outerBody, 1, "foreignCall(1)", [], 1) end local (* Build a callback. First apply the compiler to the abi/argtype/restype values. Then apply the result to a function to generate the final C callback code. The C callback code calls the function with two arguments. Here we have to pass it a function that expects a tuple and unwrap it. *) val innerMost = mkInlproc(mkEval(mkLoadClosure 0, [mkTuple[arg0, arg1]]), 2, "buildCallBack(1)(1)2", [mkLoadArgument 0], 0) val resultFn = mkInlproc(mkEval(mkLoadClosure 0, [innerMost]), 1, "buildCallBack(1)(1)", [mkLoadLocal 0], 0) val firstBuild = mkEval(mkConst (toMachineWord CODETREE.Foreign.buildCallBack), [arg0]) val outerBody = mkEnv([mkDec(0, firstBuild)], resultFn) in val buildCallBackEntry = mkInlproc(outerBody, 1, "buildCallBack(1)", [], 1) end (* Abi - an eqtype. An enumerated type or short int. *) local open TypeValue fun monotypePrinter _ = PRETTY.PrettyString "?" val code = createTypeValue{ eqCode = equalTaggedWordFn, printCode = mkConst (toMachineWord (ref monotypePrinter)), boxedCode = boxedNever, sizeCode = singleWord } val abiEqAndPrint = Global (genCode(code, [], 0) ()) in val abiConstr = makeTypeConstructor("abi", [], makeFreeId(0, abiEqAndPrint, true, basisDescription "Foreign.LowLevel.abi"), declInBasis) end val () = #enterType foreignEnv ("abi", TypeConstrSet(abiConstr, [])) val abiType = mkTypeConstruction ("abi", abiConstr, [], declInBasis) (* It would be possible to put the definition of cType in here but it's complicated. It's easier to use an opaque type and put in a cast later. *) val ctypeConstr = makeTypeConstructor("ctype", [], makeFreeId(0, defaultEqAndPrintCode(), false, basisDescription "Foreign.LowLevel.ctype"), declInBasis) val () = #enterType foreignEnv ("ctype", TypeConstrSet(ctypeConstr, [])) val ffiType = mkTypeConstruction ("ctype", ctypeConstr, [], declInBasis) val foreignCallType = mkProductType[abiType, List ffiType, ffiType] ->> mkProductType[LargeWord, LargeWord, LargeWord] ->> Unit val buildCallBackType = mkProductType[abiType, List ffiType, ffiType] ->> (mkProductType[LargeWord, LargeWord] ->> Unit) ->> LargeWord fun enterForeign (name, entry, typ) = #enterVal foreignEnv (name, mkGvar (name, typ, entry, declInBasis)) in val () = enterForeign("foreignCall", foreignCallEntry, foreignCallType) val () = enterForeign("buildCallBack", buildCallBackEntry, buildCallBackType) (* Apply the abiList function here. The ABIs depend on the platform in the interpreted version. *) val () = enterForeign("abiList", mkConst(toMachineWord(CODETREE.Foreign.abiList())), List (String ** abiType)) end local fun addVal (name : string, value : 'a, typ : types) : unit = enterBootstrap (name, mkConst (toMachineWord value), typ) (* These are only used during the bootstrap phase. Replacements are installed once the appropriate modules of the basis library are compiled. *) fun intOfString s = let val radix = if String.size s >= 3 andalso String.substring(s, 0, 2) = "0x" orelse String.size s >= 4 andalso String.substring(s, 0, 3) = "~0x" then StringCvt.HEX else StringCvt.DEC in case StringCvt.scanString (Int.scan radix) s of NONE => raise Conversion "Invalid integer constant" | SOME res => res end fun wordOfString s = let val radix = if String.size s > 2 andalso String.sub(s, 2) = #"x" then StringCvt.HEX else StringCvt.DEC in case StringCvt.scanString (Word.scan radix) s of NONE => raise Conversion "Invalid word constant" | SOME res => res end open PRINTTABLE val convstringCode = genCode(mkConst(toMachineWord unescapeString), [], 0) () val convintCode = genCode(mkConst(toMachineWord intOfString), [], 0) () val convwordCode = genCode(mkConst(toMachineWord wordOfString), [], 0) () in (* Conversion overloads used to be set by the ML bootstrap code. It's simpler to do that here but to maintain compatibility with the 5.6 compiler we need to define these. Once we've rebuilt the compiler this can be removed along with the code that uses it. *) val () = addVal ("convStringName", "convString": string, String) val () = addVal ("convInt", intOfString : string -> int, String ->> intInfType) val () = addVal ("convWord", wordOfString : string -> word, String ->> Word) (* Convert a string, recognising and converting the escape codes. *) val () = addVal ("convString", unescapeString: string -> string, String ->> String) (* Flag to indicate which version of Int to compile *) val () = addVal ("intIsArbitraryPrecision", intIsArbitraryPrecision, Bool) (* Install the overloads now. *) val () = addOverload("convString", stringConstr, convstringCode) val () = addOverload("convInt", fixedIntConstr, convintCode) val () = addOverload("convInt", intInfConstr, convintCode) val () = addOverload("convWord", wordConstr, convwordCode) end (* The only reason we have vector here is to get equality right. We need vector to be an equality type and to have a specific equality function. *) local fun polyTypePrinter _ _ = PRETTY.PrettyString "?" (* The equality function takes the base equality type as an argument. The inner function takes two arguments which are the two vectors to compare, checks the lengths and if they're equal applies the base equality to each field. *) val eqCode = mkInlproc( mkProc( mkEnv([ (* Length of the items. *) mkDec(0, mkUnary(BuiltIns.MemoryCellLength, mkLoadArgument 0)), mkDec(1, mkUnary(BuiltIns.MemoryCellLength, mkLoadArgument 1)), mkMutualDecs[(2, (* Loop function. *) mkProc( mkIf( (* Finished? *) mkEqualTaggedWord(mkLoadClosure 0, mkLoadArgument 0), CodeTrue, (* Yes, all equal. *) mkIf( mkEval( TypeValue.extractEquality(mkLoadClosure 2), (* Base equality fn *) [ mkLoadOperation(LoadStoreMLWord{isImmutable=true}, mkLoadClosure 3, mkLoadArgument 0), mkLoadOperation(LoadStoreMLWord{isImmutable=true}, mkLoadClosure 4, mkLoadArgument 0) ]), mkEval(mkLoadClosure 1, (* Recursive call with index+1. *) [ mkBinary(BuiltIns.WordArith BuiltIns.ArithAdd, mkLoadArgument 0, mkConst(toMachineWord 1)) ]), CodeFalse (* Not equal elements - result false *) ) ), 1, "vector-loop", [mkLoadLocal 0 (* Length *), mkLoadLocal 2 (* Loop function *), mkLoadClosure 0 (* Base equality function *), mkLoadArgument 0 (* Vector 0 *), mkLoadArgument 1 (* Vector 1 *)], 0))] ], mkIf( (* Test the lengths. *) mkEqualTaggedWord(mkLoadLocal 0, mkLoadLocal 1), (* Equal - test the contents. *) mkEval(mkLoadLocal 2, [CodeZero]), CodeFalse (* Not same length- result false *) ) ), 2, "vector-eq", [mkLoadArgument 0], 3), 1, "vector-eq()", [], 0) val idCode = (* Polytype *) let open TypeValue val code = createTypeValue{ eqCode=eqCode, printCode=mkConst (toMachineWord (ref polyTypePrinter)), boxedCode=mkInlproc(boxedAlways, 1, "boxed-vector", [], 0), sizeCode=mkInlproc(singleWord, 1, "size-vector", [], 0)} in Global (genCode(code, [], 0) ()) end in val vectorType = makeTypeConstructor("vector", [makeTypeVariable()], makeFreeId(1, idCode, true, basisDescription "vector"), declInBasis) val () = enterGlobalType ("vector", TypeConstrSet(vectorType, [])) end (* We also need a type with byte-wise equality. *) local fun monoTypePrinter _ = PRETTY.PrettyString "?" (* This is a monotype equality function that takes two byte vectors and compares them byte-by-byte for equality. Because they are vectors of bytes it's unsafe to load the whole words which could look like addresses if the bottom bit happens to be zero. *) val eqCode = mkProc( mkEnv([ (* Length of the items. *) mkDec(0, mkUnary(BuiltIns.MemoryCellLength, mkLoadArgument 0)), mkDec(1, mkUnary(BuiltIns.MemoryCellLength, mkLoadArgument 1)) ], mkIf( (* Test the lengths. *) mkEqualTaggedWord(mkLoadLocal 0, mkLoadLocal 1), (* Equal - test the contents. *) mkEnv([ (* ByteVecEqual takes a byte length so we have to multiply by the number of bytes per word. *) mkDec(2, mkBinary(BuiltIns.WordArith BuiltIns.ArithMult, mkConst(toMachineWord RunCall.bytesPerWord), mkLoadLocal 0)) ], mkBlockOperation{kind=BlockOpEqualByte, leftBase=mkLoadArgument 0, rightBase=mkLoadArgument 1, leftIndex=CodeZero, rightIndex=CodeZero, length=mkLoadLocal 2}), CodeFalse (* Not same length- result false *) ) ), 2, "byteVector-eq", [], 3) val idCode = (* Polytype *) let open TypeValue val code = createTypeValue{ eqCode=eqCode, printCode=mkConst (toMachineWord (ref monoTypePrinter)), boxedCode=boxedAlways, sizeCode=singleWord} in Global (genCode(code, [], 0) ()) end in val byteVectorType = makeTypeConstructor("byteVector", [], makeFreeId(0, idCode, true, basisDescription "byteVector"), declInBasis) val () = #enterType bootstrapEnv ("byteVector", TypeConstrSet(byteVectorType, [])) end (* We also need array and Array2.array to be passed through here so that they have the special property of being eqtypes even if their argument is not. "array" is defined to be in the global environment. *) val () = enterGlobalType ("array", TypeConstrSet(arrayConstr, [])) val () = #enterType bootstrapEnv ("array", TypeConstrSet(array2Constr, [])) val () = #enterType bootstrapEnv ("byteArray", TypeConstrSet(byteArrayConstr, [])) (* "=', '<>', PolyML.print etc are type-specific function which appear to be polymorphic. The compiler recognises these and treats them specially. For (in)equality that means generating type-specific versions of the equality operations; for print etc that means printing in a type-specific way. They can become true polymorphic functions and lose their type-specificity. For (in)equality that means defaulting to structure equality which is normal and expected behaviour. For print etc that means losing the ability to print and just printing "?" so it's important to avoid that happening. "open" treats type-specific functions specially and retains the type-specificity. That's important to allow the prelude code to expand the PolyML structure. *) local val eqType = let val a = makeEqTV () in a ** a ->> Bool end val eqVal = mkSpecialFun("=", eqType, Equal) in val () = enterGlobalValue ("=", eqVal) end local val neqType = let val a = makeEqTV () in a ** a ->> Bool end val neqVal = mkSpecialFun("<>", neqType, NotEqual) in val () = enterGlobalValue ("<>", neqVal) end val polyMLEnv = makeStructure(globalEnv, "PolyML") val enterPolyMLVal = #enterVal polyMLEnv local (* This version of the environment must match that used in the NameSpace structure. *) open TYPETREE (* Create a new structure for them. *) val nameSpaceEnv = makeStructure(polyMLEnv, "NameSpace") (* Substructures. *) val valuesEnv = makeStructure(nameSpaceEnv, "Values") and typesEnv = makeStructure(nameSpaceEnv, "TypeConstrs") and fixesEnv = makeStructure(nameSpaceEnv, "Infixes") and structsEnv = makeStructure(nameSpaceEnv, "Structures") and sigsEnv = makeStructure(nameSpaceEnv, "Signatures") and functsEnv = makeStructure(nameSpaceEnv, "Functors") (* Types for the basic values. These are opaque. *) val valueVal = makeAndDeclareOpaqueType("value", "PolyML.NameSpace.Values.value", valuesEnv) (* Representation of the type of a value. *) val Types = makeAndDeclareOpaqueType("typeExpression", "PolyML.NameSpace.Values.typeExpression", valuesEnv) val typeVal = makeAndDeclareOpaqueType("typeConstr", "PolyML.NameSpace.TypeConstrs.typeConstr", typesEnv) val fixityVal = makeAndDeclareOpaqueType("fixity", "PolyML.NameSpace.Infixes.fixity", fixesEnv) val signatureVal = makeAndDeclareOpaqueType("signatureVal", "PolyML.NameSpace.Signatures.signatureVal", sigsEnv) val structureVal = makeAndDeclareOpaqueType("structureVal", "PolyML.NameSpace.Structures.structureVal", structsEnv) val functorVal = makeAndDeclareOpaqueType("functorVal", "PolyML.NameSpace.Functors.functorVal", functsEnv) (* nameSpace type. Labelled record. *) fun createFields(name, vType): { name: string, typeof: types} list = let val enterFun = String ** vType ->> Unit val lookupFun = String ->> Option vType val allFun = Unit ->> List (String ** vType) in [mkLabelEntry("enter" ^ name, enterFun), mkLabelEntry("lookup" ^ name, lookupFun), mkLabelEntry("all" ^ name, allFun)] end (* We have to use the same names as we use in the env type because we're passing "env" values through the bootstrap. *) val valTypes = [("Val", valueVal), ("Type", typeVal), ("Fix", fixityVal), ("Struct", structureVal), ("Sig", signatureVal), ("Funct", functorVal)] val fields = List.foldl (fn (p,l) => createFields p @ l) [] valTypes val recordType = makeTypeAbbreviation("nameSpace", "PolyML.NameSpace.nameSpace", [], mkLabelled(sortLabels fields, true), declInBasis); val () = #enterType nameSpaceEnv ("nameSpace", TypeConstrSet(recordType, [])); (* The result type of the compiler includes valueVal etc. *) val resultFields = List.map TYPETREE.mkLabelEntry [("values", List(String ** valueVal)), ("fixes", List(String ** fixityVal)), ("types", List(String ** typeVal)), ("structures", List(String ** structureVal)), ("signatures", List(String ** signatureVal)), ("functors", List(String ** functorVal))] in val nameSpaceType = mkTypeConstruction ("nameSpace", recordType, [], declInBasis) val execResult = mkLabelled(sortLabels resultFields, true) type execResult = { fixes: (string * fixStatus) list, values: (string * values) list, structures: (string * structVals) list, signatures: (string * signatures) list, functors: (string * functors) list, types: (string * typeConstrSet) list } val valueVal = valueVal val typeVal = typeVal val fixityVal = fixityVal val signatureVal = signatureVal val structureVal = structureVal val functorVal = functorVal val Types = Types val valuesEnv = valuesEnv and typesEnv = typesEnv and fixesEnv = fixesEnv and structsEnv = structsEnv and sigsEnv = sigsEnv and functsEnv = functsEnv end local val typeconstr = locationConstr val () = #enterType polyMLEnv ("location", typeconstr); in val Location = mkTypeConstruction ("location", tsConstr typeconstr, [], declInBasis) end (* Interface to the debugger. *) local open TYPETREE val debuggerEnv = makeStructure(polyMLEnv, "DebuggerInterface") (* Make these opaque at this level. *) val locationPropList = makeAndDeclareOpaqueType("locationPropList", "PolyML.DebuggerInterface.locationPropList", debuggerEnv) val typeId = makeAndDeclareOpaqueType("typeId", "PolyML.DebuggerInterface.typeId", debuggerEnv) val machineWordType = makeAndDeclareOpaqueType("machineWord", "PolyML.DebuggerInterface.machineWord", debuggerEnv) (* For long term security keep these as different from global types and sigs. Values in the static environment need to be copied before they are global. *) val localType = makeAndDeclareOpaqueType("localType", "PolyML.DebuggerInterface.localType", debuggerEnv) val localTypeConstr = makeAndDeclareOpaqueType("localTypeConstr", "PolyML.DebuggerInterface.localTypeConstr", debuggerEnv) val localSig = makeAndDeclareOpaqueType("localSig", "PolyML.DebuggerInterface.localSig", debuggerEnv) open DEBUGGER (* Entries in the static list. This type is only used within the implementation of DebuggerInterface in the basis library and does not appear in the final signature. *) val environEntryConstr = makeTypeConstructor("environEntry", [], makeFreeId(0, defaultEqAndPrintCode(), false, basisDescription "PolyML.DebuggerInterface.environEntry"), declInBasis) val environEntryType = mkTypeConstruction ("environEntry", environEntryConstr, [], declInBasis) val constrs = (* Order is significant. *) [ ("EnvEndFunction", mkProductType[String, Location, localType]), ("EnvException", mkProductType[String, localType, locationPropList]), ("EnvStartFunction", mkProductType[String, Location, localType]), ("EnvStructure", mkProductType[String, localSig, locationPropList]), ("EnvTConstr", String ** localTypeConstr), ("EnvTypeid", typeId ** typeId), ("EnvVConstr", mkProductType[String, localType, Bool, Int, locationPropList]), ("EnvValue", mkProductType[String, localType, locationPropList]) ] (* This representation must match the representation defined in DEBUGGER_.sml. *) val numConstrs = List.length constrs val {constrs=constrReps, ...} = chooseConstrRepr(constrs, []) val constructors = ListPair.map (fn ((s,t), code) => mkGconstr(s, t ->> environEntryType, code, false, numConstrs, declInBasis)) (constrs, constrReps) val () = List.app (fn c => #enterVal debuggerEnv(valName c, c)) constructors (* Put these constructors onto the type. *) val () = #enterType debuggerEnv ("environEntry", TypeConstrSet(environEntryConstr, constructors)) (* Debug state type. *) val debugStateConstr = makeTypeAbbreviation("debugState", "PolyML.DebuggerInterface.debugState", [], mkProductType[List environEntryType, List machineWordType, Location], declInBasis) val () = #enterType debuggerEnv ("debugState", TypeConstrSet(debugStateConstr, [])) val debugStateType = mkTypeConstruction ("debugState", debugStateConstr, [], declInBasis) in val () = applyList (fn (name, v, t) => #enterVal debuggerEnv (name, mkGvar (name, t, mkConst v, declInBasis))) [ ("makeValue", toMachineWord(makeValue: debugState -> string * types * locationProp list * machineWord -> values), debugStateType ->> mkProductType[String, localType, locationPropList, machineWordType] ->> valueVal), ("makeException", toMachineWord(makeException: debugState -> string * types * locationProp list * machineWord -> values), debugStateType ->> mkProductType[String, localType, locationPropList, machineWordType] ->> valueVal), ("makeConstructor", toMachineWord(makeConstructor: debugState -> string * types * bool * int * locationProp list * machineWord -> values), debugStateType ->> mkProductType[String, localType, Bool, Int, locationPropList, machineWordType] ->> valueVal), ("makeAnonymousValue", toMachineWord(makeAnonymousValue: debugState -> types * machineWord -> values), debugStateType ->> mkProductType[localType, machineWordType] ->> valueVal), ("makeStructure", toMachineWord(makeStructure: debugState -> string * signatures * locationProp list * machineWord -> structVals), debugStateType ->> mkProductType[String, localSig, locationPropList, machineWordType] ->> structureVal), ("makeTypeConstr", toMachineWord(makeTypeConstr: debugState -> typeConstrSet -> typeConstrSet), debugStateType ->> localTypeConstr ->> typeVal), ("unitValue", toMachineWord(mkGvar("", unitType, CodeZero, []): values), valueVal), (* Used as a default *) ("setOnEntry", toMachineWord(setOnEntry: (string * PolyML.location -> unit) option -> unit), Option (String ** Location ->> Unit) ->> Unit), ("setOnExit", toMachineWord(setOnExit: (string * PolyML.location -> unit) option -> unit), Option (String ** Location ->> Unit) ->> Unit), ("setOnExitException", toMachineWord(setOnExitException: (string * PolyML.location -> exn -> unit) option -> unit), Option (String ** Location ->> Exn ->> Unit) ->> Unit), ("setOnBreakPoint", toMachineWord(setOnBreakPoint: (PolyML.location * bool ref -> unit) option -> unit), Option (Location ** Ref Bool ->> Unit) ->> Unit) ] end local val typeconstr = contextConstr in val () = #enterType polyMLEnv ("context", typeconstr); val () = List.app(fn(tv as Value{name, ...}) => #enterVal polyMLEnv(name, tv)) (tsConstructors typeconstr) end local val typeconstr = prettyConstr in val () = #enterType polyMLEnv ("pretty", typeconstr); val () = List.app(fn(tv as Value{name, ...}) => #enterVal polyMLEnv(name, tv)) (tsConstructors typeconstr) val PrettyType = mkTypeConstruction ("pretty", tsConstr typeconstr, [], declInBasis) end local val printType = let val a = makePrintTV () in a ->> a end; val printVal = mkSpecialFun("print", printType, Print); in val () = enterPolyMLVal ("print", printVal); end; local val makeStringType = let val a = makePrintTV () in a ->> String end; val makeStringVal = mkSpecialFun("makestring", makeStringType, MakeString); in val () = enterPolyMLVal ("makestring", makeStringVal); end; local val prettyType = let val a = makePrintTV () in a ** fixedIntType ->> PrettyType end; val prettyVal = mkSpecialFun("prettyRepresentation", prettyType, GetPretty); in val () = enterPolyMLVal ("prettyRepresentation", prettyVal); end; local (* addPrettyPrinter is the new function to install a pretty printer. *) val a = makeTV () val b = makeTV () val addPrettyType = (TYPETREE.fixedIntType ->> b ->> a ->> PrettyType) ->> Unit; val addPrettyVal = mkSpecialFun("addPrettyPrinter", addPrettyType, AddPretty); in val () = enterPolyMLVal ("addPrettyPrinter", addPrettyVal); end; (* This goes in RunCall since it's only for the basis library. *) local val addOverloadType = let val a = makeTV () and b = makeTV () in (a ->> b) ->> String ->> Unit end; val addOverloadVal = mkSpecialFun("addOverload", addOverloadType, AddOverload); in val () = #enterVal runCallEnv ("addOverload", addOverloadVal); end local (* Add a function to switch the default integer type. *) fun setType isArbitrary = setPreferredInt(if isArbitrary then intInfConstr else fixedIntConstr) in val () = #enterVal runCallEnv ("setDefaultIntTypeArbitrary", mkGvar ("setDefaultIntTypeArbitrary", Bool ->> Unit, mkConst (toMachineWord setType), declInBasis)) end local val sourceLocVal = mkSpecialFun("sourceLocation", Unit ->> Location, GetLocation); in val () = enterPolyMLVal ("sourceLocation", sourceLocVal); end; local (* This is used as one of the arguments to the compiler function. *) open TYPETREE val uniStructEnv = makeStructure(bootstrapEnv, "Universal") fun enterUniversal (name : string, entry : codetree, typ : types) : unit = let val value = mkGvar (name, typ, entry, declInBasis); in #enterVal uniStructEnv (name, value) end; local fun polyTypePrinter _ _ = PRETTY.PrettyString "?" open TypeValue val idCode = let val code = createTypeValue{ eqCode=CodeZero, (* Not an equality type *) printCode=mkConst (toMachineWord (ref polyTypePrinter)), boxedCode=mkInlproc(boxedEither(* Assume worst case *), 1, "boxed-tag", [], 0), sizeCode=mkInlproc(singleWord, 1, "size-tag", [], 0)} in Global (genCode(code, [], 0) ()) end in (* type 'a tag *) val tagConstr = makeTypeConstructor("tag", [makeTypeVariable()], makeFreeId(1, idCode, false, basisDescription "tag"), declInBasis); val () = #enterType uniStructEnv ("tag", TypeConstrSet(tagConstr, [])) end (* type universal *) val univConstr = makeTypeConstructor("universal", [], makeFreeId(0, defaultEqAndPrintCode(), false, basisDescription "universal"), declInBasis); val () = #enterType uniStructEnv ("universal", TypeConstrSet(univConstr, [])); fun Tag base = mkTypeConstruction ("tag", tagConstr, [base], declInBasis) val Universal = mkTypeConstruction ("universal", univConstr, [], declInBasis) val a = makeTV() (* val tagInject : 'a tag -> 'a -> universal *) val injectType = Tag a ->> a ->> Universal val () = enterUniversal ("tagInject", makePolymorphic([a], mkConst (toMachineWord (Universal.tagInject: 'a Universal.tag -> 'a -> Universal.universal))), injectType) (* We don't actually need tagIs and tagProject since this is only used for the compiler. Universal is redefined in the basis library. *) val projectType = Tag a ->> Universal ->> a val () = enterUniversal ("tagProject", makePolymorphic([a], mkConst (toMachineWord(Universal.tagProject: 'a Universal.tag -> Universal.universal -> 'a))), projectType) val testType = Tag a ->> Universal ->> Bool val () = enterUniversal ("tagIs", makePolymorphic([a], mkConst (toMachineWord(Universal.tagIs: 'a Universal.tag -> Universal.universal -> bool))), testType) in val Tag = Tag and Universal = Universal end local open TYPETREE (* Parsetree properties datatype. *) val propConstr = makeTypeConstructor("ptProperties", [], makeFreeId(0, defaultEqAndPrintCode(), false, basisDescription "PolyML.ptProperties"), declInBasis); val PtProperties = mkTypeConstruction ("ptProperties", propConstr, [], declInBasis) (* Parsetree type. *) val parseTreeConstr = makeTypeAbbreviation("parseTree", "PolyML.parseTree", [], Location ** List PtProperties, declInBasis); val ParseTree = mkTypeConstruction ("parseTree", parseTreeConstr, [], declInBasis) val () = #enterType polyMLEnv ("parseTree", TypeConstrSet(parseTreeConstr, [])); val constrs = (* Order is significant. *) [ ("PTbreakPoint", Ref Bool), ("PTcompletions", List String), ("PTdeclaredAt", Location), ("PTdefId", fixedIntType), ("PTfirstChild", Unit ->> ParseTree), ("PTnextSibling", Unit ->> ParseTree), ("PTopenedAt", Location), ("PTparent", Unit ->> ParseTree), ("PTpreviousSibling", Unit ->> ParseTree), ("PTprint", fixedIntType ->> PrettyType), ("PTreferences", Bool ** List Location), ("PTrefId", fixedIntType), ("PTstructureAt", Location), ("PTtype", Types) ]; (* This representation must match the representation defined in ExportTree.sml. *) val numConstrs = List.length constrs val {constrs=constrReps, ...} = chooseConstrRepr(constrs, []) val constructors = ListPair.map (fn ((s,t), code) => mkGconstr(s, t ->> PtProperties, code, false, numConstrs, declInBasis)) (constrs, constrReps) val () = List.app (fn c => #enterVal polyMLEnv(valName c, c)) constructors (* Put these constructors onto the type. *) val () = #enterType polyMLEnv ("ptProperties", TypeConstrSet(propConstr, constructors)); in val ParseTree = ParseTree and PtProperties = PtProperties end local open TYPETREE val compilerType : types = mkProductType[nameSpaceType, Unit ->> Option Char, List Universal] ->> mkProductType[Option ParseTree, Option (Unit ->> execResult)] type compilerType = nameSpace * (unit -> char option) * Universal.universal list -> exportTree option * (unit->execResult) option in val () = enterBootstrap ("use", mkConst (toMachineWord ((useIntoEnv globalTable []): string -> unit)), String ->> Unit) val () = enterBootstrap ("useWithParms", mkConst (toMachineWord ((useIntoEnv globalTable): Universal.universal list -> string -> unit)), List Universal ->> String ->> Unit) val () = enterPolyMLVal("compiler", mkGvar ("compiler", compilerType, mkConst (toMachineWord (compiler: compilerType)), declInBasis)); val () = enterBootstrap("globalSpace", mkConst (toMachineWord(gEnvAsNameSpace globalTable: nameSpace)), nameSpaceType) end; local val ty = TYPETREE.mkOverloadSet[] val addType = ty ** ty ->> ty; val negType = ty ->> ty; val cmpType = ty ** ty ->> Bool; in val () = enterGlobalValue ("+", mkOverloaded "+" addType); val () = enterGlobalValue ("-", mkOverloaded "-" addType); val () = enterGlobalValue ("*", mkOverloaded "*" addType); val () = enterGlobalValue ("~", mkOverloaded "~" negType); val () = enterGlobalValue ("abs", mkOverloaded "abs" negType); val () = enterGlobalValue (">=", mkOverloaded ">=" cmpType); val () = enterGlobalValue ("<=", mkOverloaded "<=" cmpType); val () = enterGlobalValue (">", mkOverloaded ">" cmpType); val () = enterGlobalValue ("<", mkOverloaded "<" cmpType); (* The following overloads are added in ML97 *) val () = enterGlobalValue ("div", mkOverloaded "div" addType); val () = enterGlobalValue ("mod", mkOverloaded "mod" addType); val () = enterGlobalValue ("/", mkOverloaded "/" addType); end; local open DEBUG; local open TYPETREE val fields = [ mkLabelEntry("location", Location), mkLabelEntry("hard", Bool), mkLabelEntry("message", PrettyType), mkLabelEntry("context", Option PrettyType) ] in val errorMessageProcType = mkLabelled(sortLabels fields, true) ->> Unit type errorMessageProcType = { location: location, hard: bool, message: pretty, context: pretty option } -> unit end local open TYPETREE val optNav = Option(Unit->>ParseTree) val fields = [ mkLabelEntry("parent", optNav), mkLabelEntry("next", optNav), mkLabelEntry("previous", optNav) ] in val navigationType = mkLabelled(sortLabels fields, true) type navigationType = { parent: (unit->exportTree) option, next: (unit->exportTree) option, previous: (unit->exportTree) option } end type 'a tag = 'a Universal.tag in val () = applyList (fn (name, v, t) => enterBootstrap(name, mkConst v, t)) [ ("compilerVersion", toMachineWord (VERSION.compilerVersion: string), String), ("compilerVersionNumber", toMachineWord (VERSION.versionNumber: int), Int), ("lineNumberTag", toMachineWord (lineNumberTag : (unit->FixedInt.int) tag), Tag (Unit->>fixedIntType)), ("offsetTag", toMachineWord (offsetTag: (unit->FixedInt.int) tag), Tag (Unit->>fixedIntType)), ("fileNameTag", toMachineWord (fileNameTag: string tag), Tag String), ("bindingCounterTag", toMachineWord (bindingCounterTag: (unit->FixedInt.int) tag), Tag (Unit->>fixedIntType)), ("maxInlineSizeTag", toMachineWord (maxInlineSizeTag: FixedInt.int tag), Tag fixedIntType), ("assemblyCodeTag", toMachineWord (assemblyCodeTag: bool tag), Tag Bool), ("parsetreeTag", toMachineWord (parsetreeTag: bool tag), Tag Bool), ("codetreeTag", toMachineWord (codetreeTag: bool tag), Tag Bool), ("icodeTag", toMachineWord (icodeTag: bool tag), Tag Bool), ("lowlevelOptimiseTag", toMachineWord (lowlevelOptimiseTag: bool tag), Tag Bool), ("codetreeAfterOptTag", toMachineWord (codetreeAfterOptTag: bool tag), Tag Bool), ("inlineFunctorsTag", toMachineWord (inlineFunctorsTag: bool tag), Tag Bool), ("debugTag", toMachineWord (debugTag: bool tag), Tag Bool), ("printDepthFunTag", toMachineWord (DEBUG.printDepthFunTag: (unit->FixedInt.int) tag), Tag (Unit->>fixedIntType)), ("errorDepthTag", toMachineWord (DEBUG.errorDepthTag: FixedInt.int tag), Tag fixedIntType), ("lineLengthTag", toMachineWord (DEBUG.lineLengthTag: FixedInt.int tag), Tag fixedIntType), ("profileAllocationTag", toMachineWord (DEBUG.profileAllocationTag: FixedInt.int tag), Tag fixedIntType), ("printOutputTag", toMachineWord (PRETTY.printOutputTag: (pretty->unit) tag), Tag (PrettyType->>Unit)) , ("compilerOutputTag", toMachineWord (PRETTY.compilerOutputTag: (pretty->unit) tag), Tag (PrettyType->>Unit)), ("errorMessageProcTag", toMachineWord (LEX.errorMessageProcTag: errorMessageProcType tag), Tag errorMessageProcType), ("rootTreeTag", toMachineWord (EXPORTTREE.rootTreeTag: navigation tag), Tag navigationType), ("reportUnreferencedIdsTag", toMachineWord (reportUnreferencedIdsTag: bool tag), Tag Bool), ("reportExhaustiveHandlersTag", toMachineWord (reportExhaustiveHandlersTag: bool tag), Tag Bool), ("narrowOverloadFlexRecordTag", toMachineWord (narrowOverloadFlexRecordTag: bool tag), Tag Bool), ("createPrintFunctionsTag", toMachineWord (createPrintFunctionsTag: bool tag), Tag Bool), ("reportDiscardedValuesTag", toMachineWord (reportDiscardedValuesTag: FixedInt.int tag), Tag fixedIntType) ] end; (* PolyML.CodeTree structure. This exports the CodeTree structure into the ML space. *) local open CODETREE val codetreeEnv = makeStructure(polyMLEnv, "CodeTree") fun createType typeName = makeAndDeclareOpaqueType(typeName, "PolyML.CodeTree." ^ typeName, codetreeEnv) val CodeTree = createType "codetree" and MachineWord = createType "machineWord" and CodeBinding = createType "codeBinding" (* For the moment export these only for the general argument and result types. *) fun simpleFn (code, nArgs, name, closure, nLocals) = mkFunction{body=code, argTypes=List.tabulate(nArgs, fn _ => GeneralType), resultType=GeneralType, name=name, closure=closure, numLocals=nLocals} and simpleInlineFn (code, nArgs, name, closure, nLocals) = mkInlineFunction{body=code, argTypes=List.tabulate(nArgs, fn _ => GeneralType), resultType=GeneralType, name=name, closure=closure, numLocals=nLocals} and simpleCall(func, args) = mkCall(func, List.map (fn c => (c, GeneralType)) args, GeneralType) in val CodeTree = CodeTree val () = applyList (fn (name, v, t) => #enterVal codetreeEnv (name, mkGvar (name, t, mkConst v, declInBasis))) [ ("pretty", toMachineWord (CODETREE.pretty: codetree -> pretty), CodeTree ->> PrettyType), ("mkConstant", toMachineWord(mkConst: machineWord -> codetree), MachineWord ->> CodeTree), ("genCode", toMachineWord (genCode: codetree * Universal.universal list * int -> (unit->codetree)), mkProductType[CodeTree, List Universal, Int] ->> (Unit ->> CodeTree)), ("evalue", toMachineWord (evalue: codetree -> machineWord option), CodeTree ->> Option MachineWord), ("mkFunction", toMachineWord (simpleFn: codetree * int * string * codetree list * int -> codetree), mkProductType[CodeTree, Int, String, List CodeTree, Int] ->> CodeTree), ("mkInlineFunction", toMachineWord (simpleInlineFn: codetree * int * string * codetree list * int -> codetree), mkProductType[CodeTree, Int, String, List CodeTree, Int] ->> CodeTree), ("mkCall", toMachineWord (simpleCall: codetree * codetree list -> codetree), CodeTree ** List CodeTree ->> CodeTree), ("mkLoadLocal", toMachineWord (mkLoadLocal: int -> codetree), Int ->> CodeTree), ("mkLoadArgument", toMachineWord (mkLoadArgument: int -> codetree), Int ->> CodeTree), ("mkLoadClosure", toMachineWord (mkLoadClosure: int -> codetree), Int ->> CodeTree), ("mkDec", toMachineWord (mkDec: int * codetree -> codeBinding), Int ** CodeTree ->> CodeBinding), ("mkInd", toMachineWord (mkInd: int * codetree -> codetree), Int ** CodeTree ->> CodeTree), ("mkIf", toMachineWord (mkIf: codetree * codetree * codetree -> codetree), mkProductType[CodeTree, CodeTree, CodeTree] ->> CodeTree), ("mkWhile", toMachineWord (mkWhile: codetree * codetree -> codetree), CodeTree ** CodeTree ->> CodeTree), ("mkLoop", toMachineWord (mkLoop: codetree list -> codetree), List CodeTree ->> CodeTree), ("mkBeginLoop", toMachineWord (mkBeginLoop: codetree * (int * codetree) list -> codetree), CodeTree ** List(Int ** CodeTree) ->> CodeTree), ("mkEnv", toMachineWord (mkEnv: codeBinding list * codetree -> codetree), List CodeBinding ** CodeTree ->> CodeTree), ("mkMutualDecs", toMachineWord (mkMutualDecs: (int * codetree) list -> codeBinding), List(Int ** CodeTree) ->> CodeBinding), ("mkTuple", toMachineWord (mkTuple: codetree list -> codetree), List CodeTree ->> CodeTree), ("mkRaise", toMachineWord (mkRaise: codetree -> codetree), CodeTree ->> CodeTree), ("mkHandle", toMachineWord (mkHandle: codetree * codetree * int -> codetree), mkProductType[CodeTree, CodeTree, Int] ->> CodeTree), ("mkNullDec", toMachineWord (mkNullDec: codetree -> codeBinding), CodeTree ->> CodeBinding) ] end local (* Finish off the NameSpace structure now we have types such as pretty. *) open TYPETREE (* The exported versions expect full name spaces as arguments. Because we convert the exported versions to machineWord and give them types as data structures the compiler can't actually check that the type we give matched the internal type. *) fun makeTypeEnv NONE = { lookupType = fn _ => NONE, lookupStruct = fn _ => NONE } | makeTypeEnv(SOME(nameSpace: nameSpace)): printTypeEnv = { lookupType = fn s => case #lookupType nameSpace s of NONE => NONE | SOME t => SOME(t, NONE), lookupStruct = fn s => case #lookupStruct nameSpace s of NONE => NONE | SOME t => SOME(t, NONE) } local (* Values substructure. This also has operations related to type expressions. *) fun codeForValue (Value{access = Global code, class = ValBound, ...}) = code | codeForValue _ = raise Fail "Not a global value" and exportedDisplayTypeExp(ty, depth, nameSpace: nameSpace option) = TYPETREE.display(ty, depth, makeTypeEnv nameSpace) and exportedDisplayValues(valu, depth, nameSpace: nameSpace option) = displayValues(valu, depth, makeTypeEnv nameSpace) and propsForValue (Value {locations, typeOf, ...}) = PTtype typeOf :: mapLocationProps locations fun isConstructor (Value{class = Exception, ...}) = true | isConstructor (Value{class = Constructor _, ...}) = true | isConstructor _ = false fun isException (Value{class = Exception, ...}) = true | isException _ = false in val () = applyList (fn (name, v, t) => #enterVal valuesEnv (name, mkGvar (name, t, mkConst v, declInBasis))) [ ("name", toMachineWord (valName: values -> string), valueVal ->> String), ("print", toMachineWord (printValues: values * FixedInt.int -> pretty), mkProductType[valueVal, fixedIntType] ->> PrettyType), ("printWithType", toMachineWord (exportedDisplayValues: values * FixedInt.int * nameSpace option -> pretty), mkProductType[valueVal, fixedIntType, Option nameSpaceType] ->> PrettyType), ("printType", toMachineWord(exportedDisplayTypeExp: types * FixedInt.int * nameSpace option -> pretty), mkProductType[Types, fixedIntType, Option nameSpaceType] ->> PrettyType), ("typeof", toMachineWord (valTypeOf: values -> types), valueVal ->> Types), ("code", toMachineWord (codeForValue: values -> codetree), valueVal ->> CodeTree), ("properties", toMachineWord (propsForValue: values ->ptProperties list), valueVal ->> List PtProperties), ("isConstructor", toMachineWord(isConstructor: values -> bool), valueVal ->> Bool), ("isException", toMachineWord(isException: values -> bool), valueVal ->> Bool) ] end local (* TypeConstrs substructure. *) fun exportedDisplayTypeConstr(tyCons, depth, nameSpace: nameSpace option) = TYPETREE.displayTypeConstrs(tyCons, depth, makeTypeEnv nameSpace) and propsForTypeConstr (TypeConstrSet(TypeConstrs {locations, ...}, _)) = mapLocationProps locations and nameForType (TypeConstrSet(TypeConstrs{name, ...}, _)) = name in val () = applyList (fn (name, v, t) => #enterVal typesEnv (name, mkGvar (name, t, mkConst v, declInBasis))) [ ("name", toMachineWord(nameForType: typeConstrSet -> string), typeVal ->> String), ("print", toMachineWord (exportedDisplayTypeConstr: typeConstrSet * FixedInt.int * nameSpace option -> pretty), mkProductType[typeVal, fixedIntType, Option nameSpaceType] ->> PrettyType), ("properties", toMachineWord (propsForTypeConstr: typeConstrSet ->ptProperties list), typeVal ->> List PtProperties) ] end local (* Structures substructure *) fun exportedDisplayStructs(str, depth, nameSpace: nameSpace option) = displayStructures(str, depth, makeTypeEnv nameSpace) and codeForStruct (Struct{access = Global code, ...}) = code | codeForStruct _ = raise Fail "Not a global structure" and propsForStruct (Struct {locations, ...}) = mapLocationProps locations and nameForStruct (Struct{name, ...}) = name fun nameSpaceForStruct(baseStruct as Struct{signat=Signatures { tab, ...}, ...}): nameSpace = let open UNIVERSALTABLE fun lookupVal s = case univLookup (tab, valueVar, s) of NONE => NONE | SOME v => SOME(makeSelectedValue(v, baseStruct)) and lookupType s = case univLookup (tab, typeConstrVar, s) of NONE => NONE | SOME t => SOME(makeSelectedType(t, baseStruct)) and lookupStruct s = case univLookup (tab, structVar, s) of NONE => NONE | SOME s => SOME(makeSelectedStructure(s, baseStruct)) local fun extractItems t tab = UNIVERSALTABLE.fold (fn (s, u, l) => if Universal.tagIs t u then (s, Universal.tagProject t u) :: l else l ) [] tab in fun allValues() = map(fn (s, v) => (s, makeSelectedValue(v, baseStruct))) (extractItems valueVar tab) and allTypes() = map(fn (s, t) => (s, makeSelectedType(t, baseStruct))) (extractItems typeConstrVar tab) and allStructs() = map(fn (s, v) => (s, makeSelectedStructure(v, baseStruct))) (extractItems structVar tab) end fun enterFunction _ = raise Fail "updating a structure is not possible." (* Raise an exception for any attempt to enter a new value. Return empty for the classes that can't exist in a structure. *) in { lookupVal = lookupVal, lookupType = lookupType, lookupStruct = lookupStruct, lookupFix = fn _ => NONE, lookupSig = fn _ => NONE, lookupFunct = fn _ => NONE, enterVal = enterFunction, enterType = enterFunction, enterFix = enterFunction, enterStruct = enterFunction, enterSig = enterFunction, enterFunct = enterFunction, allVal = allValues, allType = allTypes, allStruct = allStructs, allFix = fn () => [], allSig = fn () => [], allFunct = fn () => [] } end in val () = applyList (fn (name, v, t) => #enterVal structsEnv (name, mkGvar (name, t, mkConst v, declInBasis))) [ ("name", toMachineWord(nameForStruct: structVals -> string), structureVal ->> String), ("print", toMachineWord (exportedDisplayStructs: structVals * FixedInt.int * nameSpace option -> pretty), mkProductType[structureVal, fixedIntType, Option nameSpaceType] ->> PrettyType), ("code", toMachineWord (codeForStruct: structVals -> codetree), structureVal ->> CodeTree), ("properties", toMachineWord (propsForStruct: structVals ->ptProperties list), structureVal ->> List PtProperties), ("contents", toMachineWord(nameSpaceForStruct: structVals -> nameSpace), structureVal ->> nameSpaceType) ] end local (* Signatures substructure *) fun exportedDisplaySigs(sign, depth, nameSpace: nameSpace option) = displaySignatures(sign, depth, makeTypeEnv nameSpace) and propsForSig (Signatures {locations, ...}) = mapLocationProps locations and nameForSig (Signatures{name, ...}) = name in val () = applyList (fn (name, v, t) => #enterVal sigsEnv (name, mkGvar (name, t, mkConst v, declInBasis))) [ ("name", toMachineWord(nameForSig: signatures -> string), signatureVal ->> String), ("print", toMachineWord (exportedDisplaySigs: signatures * FixedInt.int * nameSpace option -> pretty), mkProductType[signatureVal, fixedIntType, Option nameSpaceType] ->> PrettyType), ("properties", toMachineWord (propsForSig: signatures ->ptProperties list), signatureVal ->> List PtProperties) ] end local (* Functors substructure *) fun exportedDisplayFunctors(funct, depth, nameSpace: nameSpace option) = displayFunctors(funct, depth, makeTypeEnv nameSpace) and codeForFunct (Functor{access = Global code, ...}) = code | codeForFunct _ = raise Fail "Not a global functor" and propsForFunctor (Functor {locations, ...}) = mapLocationProps locations and nameForFunctor (Functor{name, ...}) = name in val () = applyList (fn (name, v, t) => #enterVal functsEnv (name, mkGvar (name, t, mkConst v, declInBasis))) [ ("name", toMachineWord(nameForFunctor: functors -> string), functorVal ->> String), ("print", toMachineWord (exportedDisplayFunctors: functors * FixedInt.int * nameSpace option -> pretty), mkProductType[functorVal, fixedIntType, Option nameSpaceType] ->> PrettyType), ("code", toMachineWord (codeForFunct: functors -> codetree), functorVal ->> CodeTree), ("properties", toMachineWord (propsForFunctor: functors ->ptProperties list), functorVal ->> List PtProperties) ] end local (* Infixes substructure *) fun nameForFix(FixStatus(s, _)) = s in val () = applyList (fn (name, v, t) => #enterVal fixesEnv (name, mkGvar (name, t, mkConst v, declInBasis))) [ ("name", toMachineWord(nameForFix: fixStatus -> string), fixityVal ->> String), ("print", toMachineWord (displayFixStatus: fixStatus -> pretty), fixityVal ->> PrettyType) ] end in end in () end (* initGlobalEnv *); end; diff --git a/mlsource/MLCompiler/LEX_.ML b/mlsource/MLCompiler/LEX_.ML index aed80c85..52786023 100644 --- a/mlsource/MLCompiler/LEX_.ML +++ b/mlsource/MLCompiler/LEX_.ML @@ -1,648 +1,648 @@ (* Original Poly version: Title: Lexical Analyser. Author: Dave Matthews, Cambridge University Computer Laboratory Copyright Cambridge University 1985 ML translation and other changes: Copyright (c) 2000 Cambridge University Technical Services Limited Further development: - Copyright (c) 2000-7, 2015-16 David C.J. Matthews + Copyright (c) 2000-7, 2015-16, 2020 David C.J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) functor LEX_ ( structure PRETTY: PRETTYSIG structure SYMBOLS : SymbolsSig -structure DEBUG: DEBUGSIG +structure DEBUG: DEBUG ) : LEXSIG = (*****************************************************************************) (* LEX functor body *) (*****************************************************************************) struct open Misc; open PRETTY; open SYMBOLS; infix 8 eq neq; type location = { file: string, startLine: FixedInt.int, startPosition: FixedInt.int, endLine: FixedInt.int, endPosition: FixedInt.int } type lexan = { stream: unit -> char option, ch: char ref, sy: sys ref, id: string ref, messageOut: { location: location, hard: bool, message: pretty, context: pretty option } -> unit, errors: bool ref, pushedSym: sys ref, extraChars: char list ref, debugParams: Universal.universal list, (* Location information. *) getLineNo: unit -> FixedInt.int, getOffset: unit -> FixedInt.int, fileName: string, startLine: FixedInt.int ref, endLine: FixedInt.int ref, startPosition: FixedInt.int ref, endPosition: FixedInt.int ref, bindingCounter: unit -> FixedInt.int }; (* The lexical analyser reads characters from the stream and updates the references in the lexan structure. That's not perhaps very ML-like but the lexical analyser can be a hot-spot in the compiler unless it's made as fast as possible. *) val eofChar = Char.chr 4; (* ctrl/D *) val isNumeric = Char.isDigit and isAlphabetic = Char.isAlpha and isWhiteSpace = Char.isSpace and isHexadecimal = Char.isHexDigit (* For our purposes we include quote and underscore. *) fun isAlphaNumeric c = Char.isAlphaNum c orelse c = #"'" orelse c = #"_" (* Print error and warning messages. *) val errorMessageProcTag: ({ location: location, hard: bool, message: pretty, context: pretty option } -> unit) Universal.tag = Universal.tag() val isOperator = Char.contains ":=<>+*!^/|&%~-?`@\\$#"; (* The initial state looks like we've just processed a complete ML declaration *) fun initial (stream, parameters) : lexan = let open DEBUG val errorMessageProc = case List.find (Universal.tagIs errorMessageProcTag) parameters of SOME f => Universal.tagProject errorMessageProcTag f | NONE => fn _ => raise Fail "Error in source code" val lineno = getParameter lineNumberTag parameters val offset = getParameter offsetTag parameters val filename = getParameter fileNameTag parameters val initialLine = lineno() (* Before the first char. *) and initialOffset = offset() val bindingCounter = getParameter bindingCounterTag parameters in { stream = stream, ch = ref #" ", (* " " - we've just "clobbered the ";" *) sy = ref Semicolon, (* ";" *) id = ref "", messageOut = errorMessageProc, errors = ref false, pushedSym = ref Othersy, extraChars = ref [], debugParams = parameters, getLineNo = lineno, getOffset = offset, fileName = filename, startLine = ref initialLine, endLine = ref initialLine, startPosition = ref initialOffset, endPosition = ref initialOffset, bindingCounter = bindingCounter } end val nullLex = initial (fn () => NONE, []); (* Error messages *) fun errorOccurred ({errors, ...}: lexan) = ! errors; fun location ({fileName, startLine, endLine, startPosition, endPosition,...}:lexan) = { file = fileName, startLine = !startLine, endLine = !endLine, startPosition = !startPosition, endPosition = !endPosition} fun reportError ({messageOut,errors,...} : lexan) (report as { hard, ...}) = ( (* If this is a hard error we have to set the flag to prevent further passes. *) if hard then errors := true else (); messageOut report ) (* Record the position of the current symbol. This sets the start for the current symbol to the last recorded end and sets the new end to the current position. *) fun setSymbolStart {getLineNo, getOffset, startLine, endLine, startPosition, endPosition, ...} = let val line = getLineNo() and offset = getOffset() in startLine := ! endLine; endLine := line; startPosition := ! endPosition; endPosition := offset end fun setSymbolEnd {getLineNo, getOffset, endLine, endPosition, ...} = let val line = getLineNo() and offset = getOffset() in endLine := line; endPosition := offset end (* Convert a piece of text into a series of words so that the pretty printing can break it into lines. *) fun breakWords str = let val words = String.tokens Char.isSpace str fun addBreaks [] = [PrettyString ""] (* Shouldn't happen *) | addBreaks [last] = [PrettyString last] | addBreaks (hd :: tl) = PrettyString hd :: PrettyBreak(1, 0) :: addBreaks tl in addBreaks words end (* Simple string error messages. *) fun errorMessage (lexan, location, message) = reportError lexan { location = location, message = PrettyBlock(3, false, [], breakWords message), hard = true, context = NONE } and warningMessage (lexan, location, message) = reportError lexan { location = location, message = PrettyBlock(3, false, [], breakWords message), hard = false, (* Just a warning *) context = NONE } (* Errors within the lexer. *) fun lexError(state, text) = ( setSymbolEnd state; errorMessage (state, location state, text) ) exception EndOfLine; (* "ch" contains the next character in the stream. extraChars is a hack that is needed to deal with a number that looks like it might be a real number but actually isn't. *) fun nextCh({ch, stream, extraChars = ref [], ...}) = ch := getOpt(stream(), eofChar) | nextCh({ch, extraChars = extra as ref(c::l), ...}) = (extra := l; ch := c) (* Skip over white space. If we have to skip we record this as the END of the previous symbol. If it turns out that the character is actually the start of a symbol then this will be set as the START by setSymbolStart. *) fun skipWhiteSpace (state as {ch = ref c, ...}:lexan) : char = if isWhiteSpace c then (setSymbolEnd state; nextCh state; skipWhiteSpace state) else c (* Leave string construction until we have all the characters. Since Single character strings are the same as single characters it doesn't cost anything to apply "str" but it allows us to conatenate with any prefix string in one go. *) fun readChars (state as { ch, ... }) (isOk: char -> bool) (s: string) : string = let fun loop (): string list = let val theChar = ! ch; in if isOk theChar then (setSymbolEnd state; nextCh state; str theChar :: loop ()) else [] end; in concat (s :: loop ()) end; (* Read in a number. *) fun parseNumber (hasMinus, state as { sy, id, ch, extraChars, ... }) = ( sy := IntegerConst; (* Copy digits into the buffer. *) id := readChars state isNumeric ""; (* May be the end of an integer, part of a real number, or w for word or x for hex. *) (* Since "0" is a valid integer what follows it is only treated as part of the integer if it is well-formed. If it is not we return the "0" as an integer constant and leave the rest to be returned. In particular that means that 0wxz is the INTEGER constant "0" followed by the identifier "wxz". N.B. ~0w1 is ~0 w1 because word constants cannot begin with ~. *) if not hasMinus andalso !ch = #"w" andalso !id = "0" then (* word constant; if it's well formed. *) ( nextCh state; if !ch = #"x" then ( nextCh state; if isHexadecimal (!ch) then ( sy := WordConst; id := readChars state isHexadecimal "0wx" ) else (extraChars := [#"x", !ch]; ch := #"w") ) else if isNumeric (!ch) then ( sy := WordConst; id := readChars state isNumeric "0w" ) else (extraChars := [!ch]; ch := #"w") ) else if !ch = #"x" andalso !id = "0" then (* Hexadecimal integer constant. *) ( nextCh state; if isHexadecimal (!ch) then id := readChars state isHexadecimal "0x" else (extraChars := [!ch]; ch := #"x") ) else if !ch = #"." orelse !ch = #"E" orelse !ch = #"e" (* "e" is allowed in ML97 *) then (* possible real constant. *) ( if !ch = #"." then ( sy := RealConst; (* Add the "." to the string. *) id := !id ^ "."; nextCh state; (* Must be followed by at least one digit. *) if not (isNumeric (!ch)) then lexError(state, "malformed real number: " ^ !id ^ str(!ch)) else id := readChars state isNumeric (!id) ) else (); (* There's a nasty here. We may actually have 1e~; which should (probably) be treated as 1 e ~ ; That means that if after we've read the e and possible ~ we find that the next character is not a digit we return the number read so far and leave the e, ~ and whatever character we found to be read next time. *) if !ch = #"E" orelse !ch = #"e" then let val eChar = !ch in nextCh state; (* May be followed by a ~ *) (* If it's followed by a digit we have an exponent otherwise we have a number followed by a identifier. In that case we have to leave the identifier until the next time we're called. *) if !ch = #"~" then ( nextCh state; if isNumeric(!ch) then (sy := RealConst; id := readChars state isNumeric (!id ^ "E~")) else (extraChars := [#"~", !ch]; ch := eChar) ) else ( if isNumeric(!ch) then (sy := RealConst; id := readChars state isNumeric (!id ^ "E")) else (extraChars := [!ch]; ch := eChar) ) end else () ) else () ); fun parseString (state as { ch, id, ... }) = let (* The original version of this simply concatenated the characters onto "id". For very long strings that's expensive since each concatenation copies the existing string, resulting in quadratic performance. This version creates a list and then implodes it. DCJM 24/5/02. *) fun getString (soFar: char list) = ( case !ch of #"\"" (* double-quote. *) => (* Finished - return result. *) (setSymbolEnd state; nextCh state; soFar) | #"\n" => (setSymbolEnd state; nextCh state; raise EndOfLine) | #"\\" => (* Escape *) let val _ = nextCh state; (* Skip the escape char. *) val next = !ch; (* Look at the next char. *) val _ = nextCh state; in (* Remove \f...\ sequences but otherwise leave the string as it is. Escape sequences are processed in the conversion function. In particular we can only decide whether \uxxxx is valid when we know whether we are converting to Ascii or Unicode. *) if isWhiteSpace next then ( if skipWhiteSpace state = #"\\" then () else ( lexError(state, "unexpected character " ^ String.toString (str (!ch)) ^" in \\ ... \\"); while !ch <> #"\\" andalso !ch <> #"\"" andalso !ch <> eofChar do nextCh state ); nextCh state; getString soFar ) else if next = #"^" (* \^c escape sequence for Control+c *) then let val next2 = !ch; val _ = nextCh state; in getString (next2 :: #"^" :: #"\\" :: soFar) end else getString (next :: #"\\" :: soFar) end | ch => (* Anything else *) ( nextCh state; if ch = eofChar then raise EndOfLine else if Char.isPrint ch (* Ok if it's printable. *) then getString (ch :: soFar) else (* Report unprintable characters. *) ( lexError(state, "unprintable character " ^ Char.toString ch ^ " found in string"); getString soFar ) ) ) in nextCh state; (* Skip the opening quote. *) id := String.implode(List.rev(getString [])) handle EndOfLine => lexError(state, "no matching quote found on this line") end (* parseString *) (* parseComment deals with nested comments. Returns with !ch containing the first character AFTER the comment. *) fun parseComment (state as { stream, ch, ... }) = let (* skipComment is called after we've already seen the "(" and "*", and returns the first chararacter AFTER the comment. *) fun skipComment () : char = let (* Returns the first chararacter AFTER the comment *) fun skipCommentBody (firstCh : char) : char = if firstCh = eofChar then ( setSymbolEnd state; lexError(state, "end of file found in comment"); firstCh ) else case (firstCh, getOpt(stream (), eofChar)) of (#"*", #")") => getOpt(stream (), eofChar) (* End of comment - return next ch. *) | (#"(", #"*") => skipCommentBody (skipComment ()) (* Nested comment. *) | (_, nextCh) => skipCommentBody nextCh in skipCommentBody (getOpt(stream (), eofChar)) (* Skip the initial "*" *) end; (* skipComment *) in ch := skipComment () end (* parseComment *); (* Sets "id" and "sy" if an identifier is read. Looks up a word to see if it is reserved. *) fun parseIdent (state as { ch, id, sy, ... }) charsetTest first (* any characters read so far *) = let val idVal = readChars state charsetTest first; in (* Qualified names may involve fields of different lexical form e.g. A.B.+ *) if !ch = #"." (* May be qualified *) then let val () = nextCh state; val c = !ch; in if isAlphabetic c then parseIdent state isAlphaNumeric (idVal ^ ".") else if isOperator c then parseIdent state isOperator (idVal ^ ".") else lexError(state, "invalid identifier - "^ idVal ^ "." ^ str c) end else ( id := idVal; sy := (if 0 < size idVal andalso String.str(String.sub(idVal, 0)) = "'" then TypeIdent else lookup idVal) ) end; (* parseIdent *) (* Main lexical analyser loop. *) fun parseToken (state as { ch, id, sy, ... }) = let val nextSym = skipWhiteSpace state (* remove leading spaces *) in setSymbolStart state; (* Set the start to the previous end and the end to after this. *) case nextSym of #"~" => (* Either an operator or part of a number. *) ( nextCh state;(* get next character *) if isNumeric (!ch) then ( (* Read the number and sets sy to integerConst. *) parseNumber(true, state); (* Prepend the "~" to the num *) id := "~" ^ !id ) else (* Part of an operator. *) parseIdent state isOperator "~" ) | #"#" =>(* Either an operator, which include a field selection or a character constant. N.B. It is not absolutely clear whether any separator is allowed between # and the following string constant. Assume that it isn't for the moment. *) ( nextCh state;(* get next character *) if !ch = #"\"" then (parseString state; sy := CharConst) else (* Part of an operator. *) parseIdent state isOperator "#" ) | #"\"" (* double quote. *) => (parseString state; sy := StringConst) | #";" => ( sy := Semicolon; (* This is a special case. If this is the final semicolon in the top-dec we mustn't read the next character because that will be put into "ch" field of this lex object and will then be discarded. Instead we clobber this with a space so that the normal space-skipping case will apply. *) ch := #" " ) | #"," => (sy := Comma; nextCh state) | #"(" => ( nextCh state; if !ch <> #"*" then sy := LeftParen else parseComment state ) | #")" => (sy := RightParen; nextCh state) | #"[" => (sy := LeftBrack; nextCh state) | #"]" => (sy := RightBrack; nextCh state) | #"_" => (sy := Underline; nextCh state) | #"{" => (sy := LeftCurly; nextCh state) | #"}" => (sy := RightCurly; nextCh state) | #"." => (* "..." *) ( nextCh state; if !ch <> #"." then lexError(state, "unknown symbol ." ^ str(!ch)) else ( setSymbolEnd state; nextCh state; if !ch <> #"." then lexError(state, "unknown symbol .." ^ str(!ch)) else (sy := ThreeDots; setSymbolEnd state; nextCh state) ) ) | firstCh => (* These can't be so easily incorporated into a "case". *) if firstCh = eofChar then sy := AbortParse else if isNumeric firstCh then parseNumber(false, state) else if isAlphabetic firstCh orelse firstCh = #"'" then parseIdent state isAlphaNumeric "" else if isOperator firstCh (* excludes ~ which has already been done *) then parseIdent state isOperator "" else let (* illegal character *) val printableFirstCh = Char.toString firstCh in (* Report the character. *) lexError(state, "unknown character \"" ^ printableFirstCh ^ "\""); nextCh state end; (* Read another token if this wasn't recognised. *) if (!sy = Othersy) then parseToken state else () end; (* parseToken *) (* Insymbol - exported interface to lexical analyser. *) fun insymbol (state as {sy,pushedSym,...}:lexan) = if ! pushedSym <> Othersy then pushedSym := Othersy (* pushedSym is a hack to handle the difficulty of parsing val ('a, 'b) f = ... compared with val (a, b) = ... and the similar fun declarations. It's also used to handle where type t = int and type ... compared with where type t = int and S = sig ...*) else ( if ! sy = AbortParse (* already end-of-file? *) then ( setSymbolStart state; lexError(state, "unexpected end of file encountered"); raise InternalError "end of file" ) else (); sy := Othersy; (* default - anything unrecognisable *) parseToken state ); (* insymbol *) fun pushBackSymbol ({pushedSym,...}:lexan, sym) = (* TODO: This does not restore the location so parses such as val () = ... get the wrong location for the opening parenthesis. *) if !pushedSym <> Othersy then raise InternalError "Attempt to push two parentheses" else pushedSym := sym (* exported version of sy and id. *) fun sy ({sy=ref sy, pushedSym = ref pushed, ...}:lexan) = if pushed <> Othersy then pushed else sy; fun id ({id=ref id,...}:lexan) = id; val debugParams = #debugParams fun newBindingId({bindingCounter, ...}: lexan) = bindingCounter() val nullLocation: location = { file="", startLine=0, startPosition=0, endLine=0, endPosition=0 } (* Construct the location that includes all the locations in the list. Used to combine the locations of individual lexical units into a location for a larger syntactic unit. *) fun locSpan ({ file, startLine, startPosition, ... }: location, { endLine, endPosition, ... }: location) = { file=file, startLine=startLine, startPosition=startPosition, endLine=endLine, endPosition=endPosition } fun errorDepth{debugParams, ...} = DEBUG.getParameter DEBUG.errorDepthTag debugParams structure Sharing = struct type pretty = pretty and lexan = lexan and sys = sys end end (* LEX functor body *); diff --git a/mlsource/MLCompiler/MAKE_.ML b/mlsource/MLCompiler/MAKE_.ML index cba76717..4156e793 100644 --- a/mlsource/MLCompiler/MAKE_.ML +++ b/mlsource/MLCompiler/MAKE_.ML @@ -1,326 +1,326 @@ (* Copyright (c) 2000 Cambridge University Technical Services Limited - Modified David C.J. Matthews 2008-9, 2015-16. + Modified David C.J. Matthews 2008-9, 2015-16, 2020. This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) (* Title: Poly Make Program. Author: Dave Matthews, Cambridge University Computer Laboratory Copyright Cambridge University 1985 *) (* This previously contained PolyML.make which was passed through to the basis. It has now been reduced to just "use" and is only used during the bootstrap process to compile the basis library itself. *) functor MAKE_ ( structure COMPILERBODY : COMPILERBODYSIG structure UNIVERSALTABLE : sig type 'a tag = 'a Universal.tag; type univTable; type universal = Universal.universal val makeUnivTable: unit -> univTable val univEnter: univTable * 'a tag * string * 'a -> unit; val univLookup: univTable * 'a tag * string -> 'a option; val univDelete: univTable * 'a tag * string -> unit; val fold: (string * universal * 'a -> 'a) -> 'a -> univTable -> 'a end; structure STRUCTVALS : STRUCTVALSIG; -structure DEBUG: DEBUGSIG +structure DEBUG: DEBUG structure PRETTY: PRETTYSIG (* For compilerOutputTag *) structure LEX: LEXSIG (* For errorMessageProcTag *) structure VERSION: sig val versionSuffix: string end sharing STRUCTVALS.Sharing = COMPILERBODY.Sharing sharing LEX.Sharing = PRETTY.Sharing ) : MAKESIG = struct type univTable = UNIVERSALTABLE.univTable; type values = STRUCTVALS.values type typeConstrs = STRUCTVALS.typeConstrs type fixStatus = STRUCTVALS.fixStatus type structVals = STRUCTVALS.structVals type signatures = STRUCTVALS.signatures type functors = STRUCTVALS.functors type env = STRUCTVALS.env open COMPILERBODY local open UNIVERSALTABLE open Thread.Thread open Thread.Mutex in (* Create an environment with a mutex to protect concurrent access. *) datatype gEnv = DbEnv of mutex * univTable (* Lock the mutex during any lookup or entry. This is primarily to avoid the underlying hash table from being rehashed by different threads at the same time. This code should be in a library. *) fun protect mutx f = let (* Turn off interrupts while we have the lock. *) val oldAttrs = getAttributes() val () = setAttributes[InterruptState InterruptDefer] val () = lock mutx val result = f() handle exn => (unlock mutx; setAttributes oldAttrs; raise exn) in unlock mutx; setAttributes oldAttrs; result end (* Create an environment *) fun makeGEnv () : gEnv = DbEnv (mutex(), makeUnivTable()); (* enter a value into an environment *) fun dbEnvEnter (DbEnv(mutx, db)) (t : 'a tag) (s : string, v : 'a) : unit = protect mutx (fn () => univEnter (db, t, s, v)) (* find a value in an environment *) fun dbEnvLookup (DbEnv(mutx, db)) (t : 'a tag) (s : string) : 'a option = protect mutx(fn () => univLookup (db, t, s)) fun dbEnvAll (DbEnv(mutx, db)) (t : 'a tag) () : (string * 'a) list = let open Universal UNIVERSALTABLE fun filter (s, c, l) = if tagIs t c then (s, tagProject t c) :: l else l in protect mutx (fn () => fold filter [] db) end fun gEnvAsEnv gEnv = STRUCTVALS.Env { lookupFix = dbEnvLookup gEnv STRUCTVALS.fixVar, lookupVal = dbEnvLookup gEnv STRUCTVALS.valueVar, lookupType = dbEnvLookup gEnv STRUCTVALS.typeConstrVar, lookupSig = dbEnvLookup gEnv STRUCTVALS.signatureVar, lookupStruct = dbEnvLookup gEnv STRUCTVALS.structVar, lookupFunct = dbEnvLookup gEnv STRUCTVALS.functorVar, enterFix = dbEnvEnter gEnv STRUCTVALS.fixVar, enterVal = dbEnvEnter gEnv STRUCTVALS.valueVar, enterType = dbEnvEnter gEnv STRUCTVALS.typeConstrVar, enterSig = dbEnvEnter gEnv STRUCTVALS.signatureVar, enterStruct = dbEnvEnter gEnv STRUCTVALS.structVar, enterFunct = dbEnvEnter gEnv STRUCTVALS.functorVar, allValNames = fn () => map #1 (dbEnvAll gEnv STRUCTVALS.valueVar ()) }; fun gEnvAsNameSpace gEnv: nameSpace = { lookupFix = dbEnvLookup gEnv STRUCTVALS.fixVar, lookupVal = dbEnvLookup gEnv STRUCTVALS.valueVar, lookupType = dbEnvLookup gEnv STRUCTVALS.typeConstrVar, lookupSig = dbEnvLookup gEnv STRUCTVALS.signatureVar, lookupStruct = dbEnvLookup gEnv STRUCTVALS.structVar, lookupFunct = dbEnvLookup gEnv STRUCTVALS.functorVar, enterFix = dbEnvEnter gEnv STRUCTVALS.fixVar, enterVal = dbEnvEnter gEnv STRUCTVALS.valueVar, enterType = dbEnvEnter gEnv STRUCTVALS.typeConstrVar, enterSig = dbEnvEnter gEnv STRUCTVALS.signatureVar, enterStruct = dbEnvEnter gEnv STRUCTVALS.structVar, enterFunct = dbEnvEnter gEnv STRUCTVALS.functorVar, allFix = dbEnvAll gEnv STRUCTVALS.fixVar, allVal = dbEnvAll gEnv STRUCTVALS.valueVar, allType = dbEnvAll gEnv STRUCTVALS.typeConstrVar, allSig = dbEnvAll gEnv STRUCTVALS.signatureVar, allStruct = dbEnvAll gEnv STRUCTVALS.structVar, allFunct = dbEnvAll gEnv STRUCTVALS.functorVar }; end; (*****************************************************************************) (* useIntoEnv (runcompiler with ML compiler bound in) *) (*****************************************************************************) fun compileIntoEnv (globalEnv : gEnv) : (string * TextIO.instream * Universal.universal list) -> unit = let val useEnv : nameSpace = { lookupFix = dbEnvLookup globalEnv STRUCTVALS.fixVar, lookupVal = dbEnvLookup globalEnv STRUCTVALS.valueVar, lookupType = dbEnvLookup globalEnv STRUCTVALS.typeConstrVar, lookupSig = dbEnvLookup globalEnv STRUCTVALS.signatureVar, lookupStruct = dbEnvLookup globalEnv STRUCTVALS.structVar, lookupFunct = dbEnvLookup globalEnv STRUCTVALS.functorVar, enterFix = dbEnvEnter globalEnv STRUCTVALS.fixVar, enterVal = dbEnvEnter globalEnv STRUCTVALS.valueVar, enterType = dbEnvEnter globalEnv STRUCTVALS.typeConstrVar, enterStruct = dbEnvEnter globalEnv STRUCTVALS.structVar, enterSig = dbEnvEnter globalEnv STRUCTVALS.signatureVar, enterFunct = dbEnvEnter globalEnv STRUCTVALS.functorVar, allFix = dbEnvAll globalEnv STRUCTVALS.fixVar, allVal = dbEnvAll globalEnv STRUCTVALS.valueVar, allType = dbEnvAll globalEnv STRUCTVALS.typeConstrVar, allSig = dbEnvAll globalEnv STRUCTVALS.signatureVar, allStruct = dbEnvAll globalEnv STRUCTVALS.structVar, allFunct = dbEnvAll globalEnv STRUCTVALS.functorVar }; fun use (fileName, inStream, parameters) = let val lineNo = ref 1; val eof = ref false; fun getChar () : char option = case TextIO.input1 inStream of eoln as SOME #"\n" => ( lineNo := !lineNo + 1; eoln ) | NONE => (eof := true; NONE) | c => c fun errorProc {message, hard, location={ file, startLine=line, ... }, ...} = TextIO.print(concat [if hard then "Error-" else "Warning-", " in '", file, "', line ", FixedInt.toString line, ".\n", PRETTY.uglyPrint message, "\n"]) in ( while not (! eof) do let open DEBUG Universal (* Compile the code *) val code = case COMPILERBODY.compiler (useEnv, getChar, parameters @ (* These will be found first and override the defaults. *) [ tagInject PRETTY.compilerOutputTag (PRETTY.prettyPrint(print, 70)), tagInject lineNumberTag (fn () => !lineNo), tagInject fileNameTag fileName, tagInject LEX.errorMessageProcTag errorProc, tagInject maxInlineSizeTag 80, tagInject reportUnreferencedIdsTag true, tagInject reportExhaustiveHandlersTag false, (* True for testing. *) (* These are only needed for debugging. *) tagInject PRETTY.printOutputTag (PRETTY.prettyPrint(print, 70)), tagInject printDepthFunTag(fn () => 20), tagInject parsetreeTag false, tagInject codetreeTag false, tagInject codetreeAfterOptTag false, tagInject icodeTag false, tagInject assemblyCodeTag false ] ) of (_, NONE) => raise Fail "Static Errors" | (_, SOME c) => c (* execute the code and get the resulting declarations. *) val { fixes, values, structures, signatures, functors, types } = code() in (* Just enter the values in the environment without printing. *) List.app (#enterFix useEnv) fixes; List.app (#enterVal useEnv) values; List.app (#enterStruct useEnv) structures; List.app (#enterSig useEnv) signatures; List.app (#enterFunct useEnv) functors; List.app (#enterType useEnv) types end ) handle Fail s => (* E.g. syntax error. *) ( TextIO.closeIn inStream; raise Fail s ) | exn => (* close inStream if an error occurs *) ( print ("Exception- " ^ General.exnName exn ^ " raised\n"); TextIO.closeIn inStream; raise exn ) end (* use *) in use end; (* scope of compileIntoEnv *) fun useIntoEnv globalEnv parameters baseName = let val () = print ("Use: " ^ baseName ^ "\n") (* See if there is a path given as a command line argument. *) val args = CommandLine.arguments(); (* If we have -I filename use that as the output name. N.B. polyImport takes the first argument that is not recognised as an RTS argument and treats that as the file name so any -I must occur AFTER the import file. *) fun getPath [] = "." (* Default path *) | getPath ("-I" :: path :: _) = path | getPath (_::tl) = getPath tl open OS.Path (* Add the path to the source on to the directory. *) val filePath = concat(getPath args, baseName) open VERSION (* See if we have a version of the file specific to this version of the compiler. For x.ML see if x.VER.ML exists. When bootstrapping from one version of the compiler to another we need to compile the basis library in both the old and new compiler. If the interface has changed we may need version-specific files. *) val { base, ext } = splitBaseExt filePath val versionName = joinBaseExt { base = joinBaseExt{base = base, ext = SOME versionSuffix}, ext = ext } val (inStream, fileName) = (TextIO.openIn versionName, versionName) handle IO.Io _ => (TextIO.openIn filePath, filePath) in compileIntoEnv globalEnv (fileName, inStream, parameters); TextIO.closeIn inStream end fun shellProc globalEnv () = compileIntoEnv globalEnv ("", TextIO.stdIn, []) fun useStringIntoEnv globalEnv str = compileIntoEnv globalEnv (str, TextIO.openString str, []) structure Sharing = struct type env = env type gEnv = gEnv type values = values type typeConstrSet = typeConstrSet type fixStatus = fixStatus type structVals = structVals type signatures = signatures type functors = functors type ptProperties = ptProperties end end; diff --git a/mlsource/MLCompiler/ParseTree/CODEGEN_PARSETREE.sml b/mlsource/MLCompiler/ParseTree/CODEGEN_PARSETREE.sml index f0d527be..518cfaae 100644 --- a/mlsource/MLCompiler/ParseTree/CODEGEN_PARSETREE.sml +++ b/mlsource/MLCompiler/ParseTree/CODEGEN_PARSETREE.sml @@ -1,1740 +1,1737 @@ (* - Copyright (c) 2013-2015 David C.J. Matthews + Copyright (c) 2013-2015, 2020 David C.J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) (* Derived from the original parse-tree Copyright (c) 2000 Cambridge University Technical Services Limited - Further development: - Copyright (c) 2000-13 David C.J. Matthews - Title: Parse Tree Structure and Operations. Author: Dave Matthews, Cambridge University Computer Laboratory Copyright Cambridge University 1985 *) functor CODEGEN_PARSETREE ( structure BASEPARSETREE : BaseParseTreeSig structure PRINTTREE: PrintParsetreeSig structure EXPORTTREE: ExportParsetreeSig structure MATCHCOMPILER: MatchCompilerSig structure LEX : LEXSIG structure CODETREE : CODETREESIG structure DEBUGGER : DEBUGGER structure TYPETREE : TYPETREESIG structure TYPEIDCODE: TYPEIDCODESIG structure STRUCTVALS : STRUCTVALSIG structure VALUEOPS : VALUEOPSSIG structure DATATYPEREP: DATATYPEREPSIG - structure DEBUG: DEBUGSIG + structure DEBUG: DEBUG structure MISC : sig (* These are handled in the compiler *) exception Conversion of string (* string to int conversion failure *) (* This isn't handled at all (except generically) *) exception InternalError of string (* compiler error *) end structure ADDRESS : AddressSig sharing BASEPARSETREE.Sharing = PRINTTREE.Sharing = EXPORTTREE.Sharing = MATCHCOMPILER.Sharing = LEX.Sharing = CODETREE.Sharing = DEBUGGER.Sharing = TYPETREE.Sharing = TYPEIDCODE.Sharing = STRUCTVALS.Sharing = VALUEOPS.Sharing = DATATYPEREP.Sharing = ADDRESS ): CodegenParsetreeSig = struct open BASEPARSETREE open PRINTTREE open EXPORTTREE open MATCHCOMPILER open CODETREE open TYPEIDCODE open LEX open TYPETREE open DEBUG open STRUCTVALS open VALUEOPS open MISC open DATATYPEREP open TypeVarMap open DEBUGGER datatype environEntry = datatype DEBUGGER.environEntry (* To simplify passing the context it is wrapped up in this type. *) type cgContext = { decName: string, debugEnv: debuggerStatus, mkAddr: int->int, level: level, typeVarMap: typeVarMap, lex: lexan, lastDebugLine: int ref, isOuterLevel: bool (* Used only to decide if we need to report non-exhaustive matches. *) } fun repDecName decName ({debugEnv, mkAddr, level, typeVarMap, lex, lastDebugLine, isOuterLevel, ...}: cgContext) = { debugEnv=debugEnv, mkAddr=mkAddr, level=level, typeVarMap=typeVarMap, decName=decName, lex=lex, lastDebugLine=lastDebugLine, isOuterLevel = isOuterLevel}: cgContext and repDebugEnv debugEnv ({decName, mkAddr, level, typeVarMap, lex, lastDebugLine, isOuterLevel, ...}: cgContext) = { debugEnv=debugEnv, mkAddr=mkAddr, level=level, typeVarMap=typeVarMap, decName=decName, lex=lex, lastDebugLine=lastDebugLine, isOuterLevel = isOuterLevel}: cgContext and repTypeVarMap typeVarMap ({decName, debugEnv, mkAddr, level, lex, lastDebugLine, isOuterLevel, ...}: cgContext) = { debugEnv=debugEnv, mkAddr=mkAddr, level=level, typeVarMap=typeVarMap, decName=decName, lex=lex, lastDebugLine=lastDebugLine, isOuterLevel = isOuterLevel}: cgContext (* Create a new level. Sets isOuterLevel to false. *) and repNewLevel(decName, mkAddr, level) ({debugEnv, lex, lastDebugLine, typeVarMap, ...}: cgContext) = { debugEnv=debugEnv, mkAddr=mkAddr, level=level, typeVarMap=typeVarMap, decName=decName, lex=lex, lastDebugLine=lastDebugLine, isOuterLevel = false}: cgContext (* Try this pipeline function *) infix |> fun a |> f = f a val singleArg = mkLoadArgument 0 (* Make a tuple out of a set of arguments or return the single argument if there is just one. *) fun mkArgTuple(from, nTuple) = if nTuple = 1 (* "tuple" is a singleton *) then mkLoadArgument from else if nTuple <= 0 then raise InternalError "mkArgTuple" else mkTuple(List.tabulate(nTuple, fn n => mkLoadArgument(n+from))) (* Load args by selecting from a tuple. *) fun loadArgsFromTuple([t], arg) = [(arg, t)](* "tuple" is a singleton *) | loadArgsFromTuple(types, arg) = ListPair.zip(List.tabulate(List.length types, fn num => mkInd (num, arg)), types) (* Return the argument/result type which is currently just floating point or everything else. *) fun getCodeArgType t = case isFloatingPt t of NONE => GeneralType | SOME FloatDouble => DoubleFloatType | SOME FloatSingle => SingleFloatType (* tupleWidth returns the width of a tuple or record or 1 if it isn't one. It is used to detect both argument tuples and results. When used for arguments the idea is that frequently a tuple is used as a way of passing multiple arguments and these can be passed on the stack. When used for results the idea is to create the result tuple on the stack and avoid garbage collector and allocator time. If we could tell that the caller was simply going to explode it we would gain but if the caller needed a tuple on the heap we wouldn't. We wouldn't actually lose if we were going to create a tuple and return it but we would lose if we exploded a tuple here and then created a new one in the caller. This version of the code assumes that if we create a tuple on one branch we're going to create one on others which may not be correct. *) (* This now returns the argument type for each entry so returns a list rather than a number. *) fun tupleWidth(TupleTree{expType=ref expType, ...}) = recordFieldMap getCodeArgType expType | tupleWidth(Labelled{expType=ref expType, ...}) = if recordNotFrozen expType (* An error, but reported elsewhere. *) then [GeneralType] (* Safe enough *) else recordFieldMap getCodeArgType expType | tupleWidth(Cond{thenpt, elsept, ...}) = ( case tupleWidth thenpt of [_] => tupleWidth elsept | w => w ) | tupleWidth(Constraint{value, ...}) = tupleWidth value | tupleWidth(HandleTree{exp, ...}) = (* Look only at the expression and ignore the handlers on the, possibly erroneous, assumption that they won't normally be executed. *) tupleWidth exp | tupleWidth(Localdec{body=[], ...}) = raise InternalError "tupleWidth: empty localdec" | tupleWidth(Localdec{body, ...}) = (* We are only interested in the last expression. *) tupleWidth(#1 (List.last body)) | tupleWidth(Case{match, ...}) = let fun getWidth(MatchTree{exp, ...}) = tupleWidth exp in List.foldl(fn(v, [_]) => getWidth v | (_, s) => s) [GeneralType] match end | tupleWidth(Parenthesised(p, _)) = tupleWidth p | tupleWidth(ExpSeq(p, _)) = tupleWidth(#1 (List.last p)) | tupleWidth(Ident{ expType=ref expType, ...}) = [getCodeArgType expType] | tupleWidth(Literal{ expType=ref expType, ...}) = [getCodeArgType expType] | tupleWidth(Applic{ expType=ref expType, ...}) = [getCodeArgType expType] | tupleWidth _ = [GeneralType] (* Start of the code-generator itself. *) (* Report unreferenced identifiers. *) fun reportUnreferencedValue lex (Value{name, references=SOME{exportedRef=ref false, localRef=ref nil, ...}, locations, ...}) = let fun getDeclLoc (DeclaredAt loc :: _) = loc | getDeclLoc (_ :: locs) = getDeclLoc locs | getDeclLoc [] = nullLocation (* Shouldn't happen. *) in warningMessage(lex, getDeclLoc locations, "Value identifier ("^name^") has not been referenced.") end | reportUnreferencedValue _ _ = () (* Process a list of possibly mutually recursive functions and identify those that are really referenced. *) fun reportUnreferencedValues(valList, lex) = let fun checkRefs valList = let fun unReferenced(Value{references=SOME{exportedRef=ref false, localRef=ref nil, ...}, ...}) = true | unReferenced _ = false val (unrefed, refed) = List.partition unReferenced valList fun update(Value{references=SOME{localRef, recursiveRef, ...}, ...}, changed) = let (* If it is referred to by a referenced function it is referenced. *) fun inReferenced(_, refName) = List.exists (fn Value{name, ...} => name=refName) refed val (present, absent) = List.partition inReferenced (!recursiveRef) in if null present then changed else ( localRef := List.map #1 present @ ! localRef; recursiveRef := absent; true ) end | update(_, changed) = changed in (* Repeat until there's no change. *) if List.foldl update false unrefed then checkRefs unrefed else () end in checkRefs valList; List.app (reportUnreferencedValue lex) valList end fun makeDebugEntries (vars: values list, {debugEnv, level, typeVarMap, lex, mkAddr, ...}: cgContext) = let val (code, newDebug) = DEBUGGER.makeValDebugEntries(vars, debugEnv, level, lex, mkAddr, typeVarMap) in (code, newDebug) end (* Add a breakpoint if debugging is enabled. The bpt argument is set in the parsetree so that it can be found by the IDE. *) fun addBreakPointCall(bpt, location, {mkAddr, level, lex, debugEnv, ...}) = let open DEBUGGER val (lineCode, newStatus) = updateDebugLocation(debugEnv, location, lex) val code = breakPointCode(bpt, location, level, lex, mkAddr) in (lineCode @ code, newStatus) end (* In order to build a call stack in the debugger we need to know about function entry and exit. *) fun wrapFunctionInDebug(codeBody, name, argCode, argType, restype, location, {debugEnv, mkAddr, level, lex, ...}) = DEBUGGER.wrapFunctionInDebug(codeBody, name, argCode, argType, restype, location, debugEnv, level, lex, mkAddr) (* Create an entry in the static environment for the function. *) (* fun debugFunctionEntryCode(name, argCode, argType, location, {debugEnv, mkAddr, level, lex, ...}) = DEBUGGER.debugFunctionEntryCode(name, argCode, argType, location, debugEnv, level, lex, mkAddr)*) (* Find all the variables declared by each pattern. *) fun getVariablesInPatt (Ident {value = ref ident, ...}, varl) = (* Ignore constructors *) if isConstructor ident then varl else ident :: varl | getVariablesInPatt(TupleTree{fields, ...}, varl) = List.foldl getVariablesInPatt varl fields | getVariablesInPatt(Labelled {recList, ...}, varl) = List.foldl (fn ({valOrPat, ...}, vl) => getVariablesInPatt(valOrPat, vl)) varl recList (* Application of a constructor: only the argument can contain vars. *) | getVariablesInPatt(Applic {arg, ...}, varl) = getVariablesInPatt (arg, varl) | getVariablesInPatt(List{elements, ...}, varl) = List.foldl getVariablesInPatt varl elements | getVariablesInPatt(Constraint {value, ...}, varl) = getVariablesInPatt(value, varl) | getVariablesInPatt(Layered {var, pattern, ...}, varl) = (* There may be a constraint on the variable so it is easiest to recurse. *) getVariablesInPatt(pattern, getVariablesInPatt(var, varl)) | getVariablesInPatt(Parenthesised(p, _), varl) = getVariablesInPatt(p, varl) | getVariablesInPatt(_, varl) = varl (* constants and error cases. *); (* If we are only passing equality types filter out the others. *) val filterTypeVars = List.filter (fn tv => not justForEqualityTypes orelse tvEquality tv) fun codeMatch(near, alt : matchtree list, arg, isHandlerMatch, matchContext as { level, mkAddr, lex, typeVarMap, ...}): codetree = let val noOfPats = length alt (* Check for unreferenced variables. *) val () = if getParameter reportUnreferencedIdsTag (debugParams lex) then let fun getVars(MatchTree{vars, ...}, l) = getVariablesInPatt(vars, l) val allVars = List.foldl getVars [] alt in List.app (reportUnreferencedValue lex) allVars end else () val lineNo = case alt of MatchTree {location, ... } :: _ => location | _ => raise Match (* Save the argument in a variable. *) val decCode = multipleUses (arg, fn () => mkAddr 1, level); (* Generate code to load it. *) val loadExpCode = #load decCode level; (* Generate a range of addresses for any functions that have to be generated for the expressions. *) val baseAddr = mkAddr noOfPats (* We want to avoid the code blowing up if we have a large expression which occurs multiple times in the resulting code. e.g. case x of [1,2,3,4] => exp1 | _ => exp2 Here exp2 will be called at several points in the code. Most patterns occur only once, sometimes a few more times. The first three times the pattern occurs the code is inserted directly. Further cases are dealt with as function calls. *) val insertDirectCount = 3 (* First three cases are inserted directly. *) (* Make an array to count the number of references to a pattern. This is used to decide whether to use a function for certain expressions or to make it inline. *) val uses = IntArray.array (noOfPats, 0); (* Called when a selection has been made to code-generate the expression. *) fun codePatternExpression pattChosenIndex = let val context = matchContext (* Increment the count for this pattern. *) val useCount = IntArray.sub(uses, pattChosenIndex) + 1 val () = IntArray.update (uses, pattChosenIndex, useCount) val MatchTree {vars, exp, breakPoint, ... } = List.nth(alt, pattChosenIndex) in if useCount <= insertDirectCount then (* Use the expression directly *) let (* If debugging add debug entries for the variables then put in a break-point. *) val vl = getVariablesInPatt(vars, []) val (envDec, varDebugEnv) = makeDebugEntries(vl, context) val (bptCode, bptEnv) = addBreakPointCall(breakPoint, getLocation exp, context |> repDebugEnv varDebugEnv) in mkEnv(envDec @ bptCode, codegen (exp, context |> repDebugEnv bptEnv)) end else let (* Put in a call to the expression as a function. *) val thisVars = getVariablesInPatt(vars, []) (* Make an argument list from the variables bound in the pattern. *) fun makeArg(Value{access=Local{addr=ref lvAddr, ...}, ...}) = mkLoadLocal lvAddr | makeArg _ = raise InternalError "makeArg" val argsForCall = List.map makeArg thisVars in mkEval(mkLoadLocal (baseAddr + pattChosenIndex), argsForCall) end end (* Generate the code and also check for redundancy and exhaustiveness. *) local val cmContext = { mkAddr = mkAddr, level = level, typeVarMap = typeVarMap, lex = lex } in val (matchCode, exhaustive) = codeMatchPatterns(alt, loadExpCode, isHandlerMatch, lineNo, codePatternExpression, cmContext) end (* Report inexhaustiveness if necessary. TODO: It would be nice to have some example of a pattern that isn't matched for. *) (* If this is a handler we may have set the option to report exhaustiveness. This helps in tracking down handlers that don't treat Interrupt specially. *) val () = if exhaustive then if isHandlerMatch andalso getParameter reportExhaustiveHandlersTag (debugParams lex) then errorNear (lex, false, near, lineNo, "Handler catches all exceptions.") else () else if isHandlerMatch then () else errorNear (lex, false, near, lineNo, "Matches are not exhaustive.") (* Report redundant patterns. *) local fun reportRedundant(patNo, 0) = let val MatchTree {location, ... } = List.nth(alt, patNo) in errorNear (lex, false, near, location, "Pattern " ^ Int.toString (patNo+1) ^ " is redundant.") end | reportRedundant _ = () in val () = IntArray.appi reportRedundant uses end (* Generate functions for expressions that have been used more than 3 times. *) fun cgExps([], _, _, _, _, _, _) = [] | cgExps (MatchTree {vars, exp, breakPoint, ...} ::al, base, patNo, uses, lex, near, cgContext as { decName, level, ...}) = if IntArray.sub(uses, patNo - 1) <= insertDirectCount then (* Skip if it has been inserted directly and we don't need a fn. *) cgExps(al, base, patNo + 1, uses, lex, near, cgContext) else let val functionLevel = newLevel level (* For the function. *) local val addresses = ref 1 in fun fnMkAddrs n = ! addresses before (addresses := !addresses + n) end val fnContext = cgContext |> repNewLevel(decName, fnMkAddrs, functionLevel) (* We have to pass the variables as arguments. Bind a local variable to the argument so we can set the variable address as a local address. *) val pattVars = getVariablesInPatt(vars, []) val noOfArgs = length pattVars val argumentList = List.tabulate(noOfArgs, mkLoadArgument) val localAddresses = List.map(fn _ => fnMkAddrs 1) pattVars (* One address for each argument. *) val localDecs = ListPair.mapEq mkDec (localAddresses, argumentList) local (* Set the addresses to be suitable for arguments. At the same time create a debugging environment if required. *) fun setAddr (Value{access=Local{addr=lvAddr, level=lvLevel}, ...}, localAddr) = (lvAddr := localAddr; lvLevel := functionLevel) | setAddr _ = raise InternalError "setAddr" in val _ = ListPair.appEq setAddr (pattVars, localAddresses) end (* If debugging add the debug entries for the variables then a break-point. *) val (envDec, varDebugEnv) = makeDebugEntries(pattVars, fnContext) val (bptCode, bptEnv) = addBreakPointCall(breakPoint, getLocation exp, fnContext |> repDebugEnv varDebugEnv) val functionBody = mkEnv(localDecs @ envDec @ bptCode, codegen (exp, fnContext |> repDebugEnv bptEnv)) val patNoIndex = patNo - 1 in mkDec(base + patNoIndex, mkProc (functionBody, noOfArgs, decName ^ "/" ^ Int.toString patNo, getClosure functionLevel, fnMkAddrs 0)) :: cgExps(al, base, patNo + 1, uses, lex, near, cgContext) end val expressionFuns = cgExps(alt, baseAddr, 1, uses, lex, near, matchContext) in (* Return the code in a block. *) mkEnv (#dec decCode @ expressionFuns, matchCode) end (* codeMatch *) (* Code-generates a piece of tree. Returns the code and also the, possibly updated, debug context. This is needed to record the last location that was set in the thread data. *) and codeGenerate(Ident {value = ref (v as Value{class = Exception, ...}), location, ...}, { level, typeVarMap, lex, debugEnv, ...}) = (* Exception identifier *) (codeExFunction (v, level, typeVarMap, [], lex, location), debugEnv) | codeGenerate(Ident {value = ref (v as Value{class = Constructor _, ...}), expType=ref expType, location, ...}, { level, typeVarMap, lex, debugEnv, ...}) = (* Constructor identifier *) let (* The instance type is not necessarily the same as the type of the value of the identifier. e.g. in the expression 1 :: nil, "::" has an instance type of int * list int -> list int but the type of "::" is 'a * 'a list -> 'a list. *) (* When using the constructor as a value we just want the second word. Must pass [] as the polyVars otherwise this will be applied BEFORE extracting the construction function not afterwards. *) fun getConstr level = ValueConstructor.extractInjection(codeVal (v, level, typeVarMap, [], lex, location)) val polyVars = getPolymorphism (v, expType, typeVarMap) val code = applyToInstance(if justForEqualityTypes then [] else polyVars, level, typeVarMap, getConstr) in (code, debugEnv) end | codeGenerate(Ident {value = ref v, expType=ref expType, location, ...}, { level, typeVarMap, lex, debugEnv, ...}) = (* Value identifier *) let val polyVars = getPolymorphism (v, expType, typeVarMap) val code = codeVal (v, level, typeVarMap, polyVars, lex, location) in (code, debugEnv) end | codeGenerate(c as Literal{converter, literal, expType=ref expType, location}, { lex, debugEnv, ...}) = ( case getLiteralValue(converter, literal, expType, fn s => errorNear(lex, true, c, location, s)) of SOME w => (mkConst w, debugEnv) | NONE => (CodeZero, debugEnv) ) | codeGenerate(Applic {f = Ident {value = ref function, expType=ref expType, ...}, arg, location, ...}, context as { level, typeVarMap, lex, ...}) = (* Some functions are special e.g. overloaded and type-specific functions. These need to picked out and processed by applyFunction. *) let val polyVars = getPolymorphism (function, expType, typeVarMap) val (argCode, argEnv) = codeGenerate (arg, context) val code = applyFunction (function, argCode, level, typeVarMap, polyVars, lex, location) in (code, argEnv) end | codeGenerate(Applic {f, arg, ...}, context) = let val (fnCode, fnEnv) = codeGenerate(f, context) val (argCode, argEnv) = codeGenerate(arg, context |> repDebugEnv fnEnv) in (mkEval (fnCode, [argCode]), argEnv) end | codeGenerate(Cond {test, thenpt, elsept, thenBreak, elseBreak, ...}, context) = let val (testCode, testEnv) = codeGenerate(test, context) val (thenBptCode, thenDebug) = addBreakPointCall(thenBreak, getLocation thenpt, context |> repDebugEnv testEnv) val (thenCode, _) = codeGenerate(thenpt, context |> repDebugEnv thenDebug) val (elseBptCode, elseDebug) = addBreakPointCall(elseBreak, getLocation elsept, context |> repDebugEnv testEnv) val (elseCode, _) = codeGenerate(elsept, context |> repDebugEnv elseDebug) in (mkIf (testCode, mkEnv(thenBptCode, thenCode), mkEnv(elseBptCode, elseCode)), testEnv) end | codeGenerate(TupleTree{fields=[(*pt*)_], ...}, _) = (* There was previously a special case to optimise unary tuples but I can't understand how they can occur. Check this and remove the special case if it really doesn't. *) raise InternalError "codegen: Unary tuple" (*codegen (pt, context)*) | codeGenerate(TupleTree{fields, ...}, context as { debugEnv, ...}) = (* Construct a vector of objects. *) (mkTuple(map (fn x => codegen (x, context)) fields), debugEnv) | codeGenerate(Labelled {recList = [{valOrPat, ...}], ...}, context) = codeGenerate (valOrPat, context) (* optimise unary records *) | codeGenerate(Labelled {recList, expType=ref expType, ...}, context as { level, mkAddr, debugEnv, ...}) = let (* We must evaluate the expressions in the order they are written. This is not necessarily the order they appear in the record. *) val recordSize = length recList; (* The size of the record. *) (* First declare the values as local variables. *) (* We work down the list evaluating the expressions and putting the results away in temporaries. When we reach the end we construct the tuple by asking for each entry in turn. *) fun declist [] look = ([], mkTuple (List.tabulate (recordSize, look))) | declist ({name, valOrPat, ...} :: t) look = let val thisDec = multipleUses (codegen (valOrPat, context), fn () => mkAddr 1, level); val myPosition = entryNumber (name, expType); fun lookFn i = if i = myPosition then #load thisDec (level) else look i val (otherDecs, tuple) = declist t lookFn in (#dec thisDec @ otherDecs, tuple) end in (* Create the record and package it up as a block. *) (mkEnv (declist recList (fn _ => raise InternalError "missing in record")), debugEnv) end | codeGenerate(c as Selector {name, labType, location, typeof, ...}, { decName, typeVarMap, lex, debugEnv, ...}) = let (* Check that the type is frozen. *) val () = if recordNotFrozen labType then errorNear (lex, true, c, location, "Can't find a fixed record type.") else (); val selectorBody : codetree = if recordWidth labType = 1 then singleArg (* optimise unary tuples - no indirection! *) else let val offset : int = entryNumber (name, labType); in mkInd (offset, singleArg) end val code =(* Make an inline function. *) case filterTypeVars (getPolyTypeVars(typeof, mapTypeVars typeVarMap)) of [] => mkInlproc (selectorBody, 1, decName ^ "#" ^ name, [], 0) | polyVars => (* This may be polymorphic. *) mkInlproc( mkInlproc (selectorBody, 1, decName ^ "#" ^ name, [], 0), List.length polyVars, decName ^ "#" ^ name ^ "(P)", [], 0) in (code, debugEnv) end | codeGenerate(Unit _, { debugEnv, ...}) = (* Use zero. It is possible to have () = (). *) (CodeZero, debugEnv) | codeGenerate(List{elements, expType = ref listType, location, ...}, context as { level, typeVarMap, lex, debugEnv, ...}) = let (* Construct a list. We need to apply the constructors appropriate to the type. *) val baseType = case listType of TypeConstruction{args=[baseType], ...} => baseType | _ => raise InternalError "List: bad element type" val consType = mkFunctionType(mkProductType[baseType, listType], listType) fun consList [] = let (* "nil" *) val polyVars = getPolymorphism (nilConstructor, listType, typeVarMap) fun getConstr level = ValueConstructor.extractInjection( codeVal (nilConstructor, level, typeVarMap, [], lex, location)) in applyToInstance(polyVars, level, typeVarMap, getConstr) end | consList (h::t) = let (* :: *) val H = codegen (h, context) and T = consList t val polyVars = getPolymorphism (consConstructor, consType, typeVarMap) in applyFunction (consConstructor, mkTuple [H,T], level, typeVarMap, polyVars, lex, location) end in (consList elements, debugEnv) end | codeGenerate(Constraint {value, ...}, context) = codeGenerate (value, context) (* code gen. the value *) | codeGenerate(c as Fn { location, expType=ref expType, ... }, context as { typeVarMap, debugEnv, ...}) = (* Function *) (codeLambda(c, location, filterTypeVars(getPolyTypeVars(expType, mapTypeVars typeVarMap)), context), debugEnv) | codeGenerate(Localdec {decs, body, ...}, context) = (* Local expressions only. Local declarations will be handled by codeSequence.*) let (* This is the continuation called when the declarations have been processed. We need to ensure that if there are local datatypes we make new entries in the type value cache after them. *) (* TODO: This is a bit of a mess. We want to return the result of the last expression as an expression rather than a codeBinding. *) fun processBody (previousDecs: codeBinding list, nextContext as {debugEnv, ...}) = let fun codeList ([], d) = ([], d) | codeList ((p, bpt) :: tl, d) = (* Generate any break point code first, then this entry, then the rest. *) let val (lineChange, newEnv) = addBreakPointCall(bpt, getLocation p, nextContext |> repDebugEnv d) (* addBreakPointCall also updates the location info in case of a break-point or a function call. We want to pass that along. *) val code = mkNullDec(codegen (p, nextContext |> repDebugEnv newEnv)) val (codeRest, finalEnv) = codeList (tl, newEnv) in (lineChange @ [code] @ codeRest, finalEnv) end val (exps, finalDebugEnv) = codeList (body, debugEnv) in (previousDecs @ exps, finalDebugEnv) end val (decs, lastEnv) = codeSequence (decs, [], context, processBody) in (decSequenceWithFinalExp decs, lastEnv) end | codeGenerate(ExpSeq(ptl, _), context as { debugEnv, ...}) = (* Sequence of expressions. Discard results of all except the last.*) let fun codeList ([], _) = raise InternalError "ExpSeq: empty sequence" | codeList ((p, bpt)::tl, d) = let val (bptCode, newEnv) = addBreakPointCall(bpt, getLocation p, context |> repDebugEnv d) (* Because addBreakPointCall updates the location info in the debug env we need to pass this along in the same way as when making bindings. *) val (thisCode, postCodeEnv) = codeGenerate (p, context |> repDebugEnv newEnv) in case tl of [] => (bptCode, thisCode, postCodeEnv) | tl => let val (otherDecs, expCode, postListEnv) = codeList(tl, postCodeEnv) in (bptCode @ (mkNullDec thisCode :: otherDecs), expCode, postListEnv) end end val (codeDecs, codeExp, finalEnv) = codeList(ptl, debugEnv) in (mkEnv (codeDecs, codeExp), finalEnv) end | codeGenerate(Raise (pt, location), context as { level, mkAddr, ...}) = let val (raiseCode, raiseEnv) = codeGenerate(pt, context) val {dec, load} = multipleUses (raiseCode, fn () => mkAddr 1, level) val load = load level (* Copy the identifier, name and argument from the packet and add this location. *) val excPacket = mkEnv(dec, mkTuple[mkInd(0, load), mkInd(1, load), mkInd(2, load), codeLocation location]) in (mkRaise excPacket, raiseEnv) end | codeGenerate(c as HandleTree {exp, hrules, ...}, context as { debugEnv, mkAddr, ...}) = (* Execute an expression in the scope of a handler *) let val exPacketAddr = mkAddr 1 val handleExp = codegen (exp, context) val handlerCode = codeMatch (c, hrules, mkLoadLocal exPacketAddr, true, context) in (mkHandle (handleExp, handlerCode, exPacketAddr), debugEnv) end | codeGenerate(While {test, body, breakPoint, ...}, context as { debugEnv, ...}) = let val (testCode, testEnv) = codeGenerate(test, context) val (bptCode, testDebug) = addBreakPointCall(breakPoint, getLocation body, context |> repDebugEnv testEnv) val (bodyCode, _) = codeGenerate(body, context |> repDebugEnv testDebug) in (mkWhile (testCode, mkEnv(bptCode, bodyCode)), debugEnv) end | codeGenerate(c as Case {test, match, ...}, context as { debugEnv, ...}) = (* The matches are made into a series of tests and applied to the test expression. *) let val testCode = codegen (test, context) in (codeMatch (c, match, testCode, false, context), debugEnv) end | codeGenerate(Andalso {first, second, ...}, context) = let val (firstCode, firstEnv) = codeGenerate(first, context) (* Any updates to the debug context in the first part will carry over but we can't be sure whether any of the second part will be executed. *) val (secondCode, _) = codeGenerate(second, context |> repDebugEnv firstEnv) in (* Equivalent to if first then second else false *) (mkCand (firstCode, secondCode), firstEnv) end | codeGenerate(Orelse {first, second, ...}, context) = let val (firstCode, firstEnv) = codeGenerate(first, context) (* Any updates to the debug context in the first part will carry over but we can't be sure whether any of the second part will be executed. *) val (secondCode, _) = codeGenerate(second, context |> repDebugEnv firstEnv) in (* Equivalent to if first then true else second *) (mkCor (firstCode, secondCode), firstEnv) end | codeGenerate(Parenthesised(p, _), context) = codeGenerate (p, context) | codeGenerate(_, {debugEnv, ...}) = (CodeZero, debugEnv) (* empty and any others *) (* Old codegen function which discards the debug context. *) and codegen (c: parsetree, context) = #1 (codeGenerate(c, context)) (* Code-generate a lambda (fn expression). *) and codeLambda(c, location, polyVars, cpContext as {mkAddr=originalmkAddr, level=originalLevel, decName, ...}) = let fun getFnBody (Constraint {value, ...}) = getFnBody value | getFnBody (Fn{matches, ...}) = matches | getFnBody (Parenthesised(p, _)) = getFnBody p | getFnBody _ = raise InternalError "getFnBody: not a constrained fn-expression"; val f = getFnBody c; (* This function comprises a new declaration level *) val nLevel = if null polyVars then originalLevel else newLevel originalLevel local val addresses = ref 1 in fun fnMkAddr n = (! addresses) before (addresses := ! addresses + n) end val (firstPat, resType, argType) = case f of MatchTree {vars, resType = ref rtype, argType = ref atype, ...} :: _ => (vars, rtype, atype) | _ => raise InternalError "codeLambda: body of fn is not a clause list"; val tupleSize = List.length(tupleWidth firstPat) in if tupleSize <> 1 andalso null polyVars then let (* If the first pattern is a tuple we make a tuple from the arguments and pass that in. Could possibly treat labelled records in the same way but we have the problem of finding the size of the record. Currently, we don't apply this optimisation if the function is polymorphic. *) val newDecName : string = decName ^ "(" ^ Int.toString tupleSize ^ ")"; val fnLevel = newLevel nLevel val argumentCode = mkArgTuple(0, tupleSize) val newContext = cpContext |> repNewLevel(newDecName, fnMkAddr, fnLevel) fun codeAlts newDebugEnv = let val bodyContext = newContext |> repDebugEnv newDebugEnv in codeMatch (c, f, argumentCode, false, bodyContext) end val wrap = wrapFunctionInDebug(codeAlts, newDecName, argumentCode, argType, resType, location, newContext) val mainProc = mkProc(wrap, tupleSize, newDecName, getClosure fnLevel, fnMkAddr 0) (* Now make a block containing the procedure which expects multiple arguments and an inline procedure which expects a single tuple argument and calls the main procedure after taking the tuple apart. *) val thisDec = multipleUses (mainProc, fn () => originalmkAddr 1, originalLevel); val resProc = (* Result procedure. *) let val nLevel = newLevel originalLevel in mkInlproc (mkEval(#load thisDec nLevel, List.map #1 (loadArgsFromTuple(List.tabulate(tupleSize, fn _ => GeneralType), singleArg))), 1, decName ^ "(1)", getClosure nLevel, 0) end in mkEnv(#dec thisDec, resProc) end else let (* No tuple or polymorphic. *) val newDecName : string = decName ^ "(1)"; val fnLevel = newLevel nLevel val newContext = cpContext |> repNewLevel(newDecName, fnMkAddr, fnLevel) fun codeAlts newDebugEnv = let val bodyContext = newContext |> repDebugEnv newDebugEnv in codeMatch (c, f, mkLoadArgument 0, false, bodyContext) end (* If we're debugging add the debug info before resetting the level. *) val wrapped = wrapFunctionInDebug(codeAlts, newDecName, mkLoadArgument 0, argType, resType, location, newContext) val pr = mkProc (wrapped, 1, newDecName, getClosure fnLevel, fnMkAddr 0) in if null polyVars then pr else mkProc(pr, List.length polyVars, newDecName^"(P)", getClosure nLevel, 0) end end (* codeLambda *) (* Code-generates a sequence of declarations. *) and codeSequence ([], leading, codeSeqContext, processBody): codeBinding list * debuggerStatus = processBody(leading, codeSeqContext) (* Do the continuation. *) | codeSequence ((firstEntry as FunDeclaration {dec, ...}, _) :: pTail, leading, codeSeqContext, processBody) = let val (firstDec, firstEnv) = codeFunBindings(dec, firstEntry, codeSeqContext) in codeSequence (pTail, leading @ firstDec, codeSeqContext |> repDebugEnv firstEnv, processBody) end | codeSequence ((firstEntry as ValDeclaration {dec, location, ...}, bpt) :: pTail, leading, codeSeqContext as {lex, ...}, processBody) = let (* Check the types for escaped datatypes. *) local fun checkVars(ValBind{variables=ref vars, line, ...}) = List.app(fn var => checkForEscapingDatatypes(valTypeOf var, fn message => errorNear (lex, true, firstEntry, line, message))) vars in val () = List.app checkVars dec end (* Put in a break point *) val (bptCode, bptDbEnv) = addBreakPointCall(bpt, location, codeSeqContext) val postBptContext = codeSeqContext |> repDebugEnv bptDbEnv (* Split the bindings into recursive and non-recursive. These have to be processed differently. *) val (recBindings, nonrecBindings) = List.partition(fn ValBind{isRecursive, ...} => isRecursive) dec val nonRecCode = codeNonRecValBindings(nonrecBindings, firstEntry, postBptContext) val recCode = case recBindings of [] => [] | _ => #1 (codeRecValBindings(recBindings, firstEntry, postBptContext)) (* Construct the debugging environment by loading all variables. *) val vars = List.foldl(fn (ValBind{variables=ref v, ...}, vars) => v @ vars) [] dec val (decEnv, env) = makeDebugEntries (vars, postBptContext) in codeSequence (pTail, leading @ bptCode @ nonRecCode @ recCode @ decEnv, codeSeqContext |> repDebugEnv env, processBody) end | codeSequence ((Localdec {decs, body, varsInBody=ref vars, ...}, _) :: pTail, leading, codeSeqContext, processBody) = let (* Local declarations only *) (* The debug environment needs to reflect the local...in...end structure but if there are local datatypes we need to process all subsequent declarations in the scope of the "stopper" we've put onto the typeVarMap. *) fun processTail(previous, newContext) = let (* The debug env for the tail is the original environment together with the variables in the body, excluding variables in the local...in part. *) val (decEnv, resEnv) = makeDebugEntries (vars, codeSeqContext) (* Original context. *) in codeSequence (pTail, previous @ decEnv, newContext |> repDebugEnv resEnv, processBody) end in (* Process the declarations then the tail. *) codeSequence (decs @ body, leading, codeSeqContext, processTail) end | codeSequence ((ExDeclaration(tlist, _), _) :: pTail, leading, codeSeqContext as {mkAddr, level, typeVarMap, lex, ...}, processBody) = let fun codeEx (ExBind{value=ref exval, previous, ... }) = let val ex = exval; (* This exception is treated in the same way as a local variable except that the value it contains is created by generating a word on the heap. The address of this word constitutes a unique identifier. Non-generative exception bindings i.e. exception ex=ex' merely copy the word from the previous exception. *) val (lvAddr, lvLevel, exType) = case ex of Value{access=Local{addr, level}, typeOf, ...} => (addr, level, typeOf) | _ => raise InternalError "lvAddr" in lvAddr := mkAddr 1; lvLevel := level; mkDec (! lvAddr, case previous of EmptyTree => (* Generate a new exception. This is a single mutable word which acts as a token. It is a mutable to ensure that there is precisely one copy of it. It contains a function to print values of the type so when we raise the exception we can print the exception packet without knowing the type. *) mkExIden (exType, level, typeVarMap) | Ident{value=ref prevVal, location, ...} => (* Copy the previous value. N.B. We want the exception identifier here so we can't call codegen. *) codeVal (prevVal, level, typeVarMap, [], lex, location) | _ => raise InternalError "codeEx" ) end (* codeEx *); val exdecs = map codeEx tlist fun getValue(ExBind{value=ref exval, ...}) = exval val (debugDecs, newDebugEnv) = makeDebugEntries(map getValue tlist, codeSeqContext) in codeSequence (pTail, leading @ exdecs @ debugDecs, codeSeqContext |> repDebugEnv newDebugEnv, processBody) end (* ExDeclaration *) | codeSequence ( (AbsDatatypeDeclaration {typelist, declist, equalityStatus = ref absEq, isAbsType, withtypes, ...}, _) :: pTail, leading, codeSeqContext as {mkAddr, level, typeVarMap, debugEnv, lex, ...}, processBody) = let (* Code-generate the eq and print functions for the abstype first then the declarations, which may use these. *) (* The debugging environment for the declarations should include the constructors but the result shouldn't. For the moment ignore the constructors. *) val typeCons = List.map(fn (DatatypeBind {tcon = ref tc, ...}) => tc) typelist val eqStatus = if isAbsType then absEq else List.map (tcEquality o tsConstr) typeCons local fun getConstrCode(DatatypeBind {tcon = ref (tc as TypeConstrSet(_, constrs)), typeVars, ...}, eqStatus) = let (* Get the argument types or EmptyType if this is nullary. *) fun getConstrType(Value{typeOf=FunctionType{arg, ...}, name, ...}) = (name, arg) | getConstrType(Value{name, ...}) = (name, EmptyType) val constrTypesAndNames = List.map getConstrType constrs val {constrs, boxed, size} = chooseConstrRepr(constrTypesAndNames, List.map TypeVar typeVars) in ({typeConstr=tc, eqStatus=eqStatus, boxedCode=boxed, sizeCode=size}, constrs) end in val constrAndBoxSizeCode = ListPair.mapEq getConstrCode (typelist, eqStatus) val (tcEqBoxSize, constrsCode) = ListPair.unzip constrAndBoxSizeCode end local fun decConstrs(DatatypeBind {tcon = ref (TypeConstrSet(_, constrs)), ...}, reprs, (decs, debugEnv)) = let (* Declare the constructors as local variables. *) fun decCons(Value{access=Local{addr, level=lev}, ...}, repr) = let val newAddr = mkAddr 1 in addr := newAddr; lev := level; mkDec(newAddr, repr) end | decCons _ = raise InternalError "decCons: Not local" val constrDecs = ListPair.map decCons (constrs, reprs) val (newDecs, newDebug) = makeDebugEntries(constrs, codeSeqContext |> repDebugEnv debugEnv) in (constrDecs @ decs @ newDecs, newDebug) end in val (valConstrDecs: codeBinding list, constrDebugenv: debuggerStatus) = ListPair.foldl decConstrs ([], debugEnv) (typelist, constrsCode) end val typeFunctions = createDatatypeFunctions(tcEqBoxSize, mkAddr, level, typeVarMap, getParameter createPrintFunctionsTag (debugParams lex)) local (* Create debug entries for the type constructors and the new type ids. *) val (dataTypeDebugDecs, dataTypeDebugEnv) = makeTypeConstrDebugEntries(typeCons, constrDebugenv, level, lex, mkAddr) val withTypeTypes = List.map(fn (TypeBind {tcon = ref tc, ...}) => tc) withtypes val (withTypeDebugDecs, withTypeDebugEnv) = makeTypeConstrDebugEntries(withTypeTypes, dataTypeDebugEnv, level, lex, mkAddr) in val typeDebugDecs = dataTypeDebugDecs @ withTypeDebugDecs val typeDebugEnv = withTypeDebugEnv end (* Mark these in the type value cache. If they are used in subsequent polymorphic IDs we must create them after this. *) val newTypeVarMap = markTypeConstructors(List.map tsConstr typeCons, mkAddr, level, typeVarMap) (* Process the with..end part. We have to restore the equality attribute for abstypes here in case getPolymorphism requires it. *) val () = if isAbsType then ListPair.appEq(fn(TypeConstrSet(tc, _), eqt) => tcSetEquality (tc, eqt)) (typeCons, absEq) else () val (localDecs, newDebug) = codeSequence (declist, [], codeSeqContext |> repDebugEnv typeDebugEnv |> repTypeVarMap newTypeVarMap, fn (code, {debugEnv, ...}) => (code, debugEnv)) val () = if isAbsType then List.app(fn TypeConstrSet(tc, _) => tcSetEquality (tc, false)) typeCons else () (* Then the subsequent declarations. *) val (tailDecs, finalEnv) = codeSequence (pTail, [], codeSeqContext |> repDebugEnv newDebug |> repTypeVarMap newTypeVarMap, processBody) in (* The code consists of previous declarations, the value constructors, the type IDs, debug declarations for the types and value constructors, any type values created for subsequent polymorphic calls, declarations in with...end and finally code after this declaration within the same "let..in..end" block. *) (leading @ valConstrDecs @ typeFunctions @ typeDebugDecs @ getCachedTypeValues newTypeVarMap @ localDecs @ tailDecs, finalEnv) end | codeSequence ((OpenDec {variables=ref vars, structures = ref structs, typeconstrs = ref types, ...}, _) :: pTail, leading, codeSeqContext as { level, lex, mkAddr, ...}, processBody) = let (* All we need to do here is make debugging entries. *) val (firstDec, firstEnv) = makeDebugEntries(vars, codeSeqContext) val (secondDec, secondEnv) = makeTypeConstrDebugEntries(types, firstEnv, level, lex, mkAddr) val (thirdDec, thirdEnv) = makeStructDebugEntries(structs, secondEnv, level, lex, mkAddr) in codeSequence (pTail, leading @ firstDec @ secondDec @ thirdDec, codeSeqContext |> repDebugEnv thirdEnv, processBody) end | codeSequence ((TypeDeclaration (typebinds, _), _) :: pTail, leading, codeSeqContext as { debugEnv, level, lex, mkAddr, ...}, processBody) = let (* Just create debug entries for the type constructors. *) val typeCons = List.map(fn (TypeBind {tcon = ref tc, ...}) => tc) typebinds val (typeDebugDecs, typeDebugEnv) = makeTypeConstrDebugEntries(typeCons, debugEnv, level, lex, mkAddr) in codeSequence (pTail, leading @ typeDebugDecs, codeSeqContext |> repDebugEnv typeDebugEnv, processBody) end | codeSequence (_ :: pTail, leading, (* Directive *) codeSeqContext, processBody) = codeSequence (pTail, leading, codeSeqContext, processBody) (* Code generate a set of fun bindings. This is used for other function creation as well since it handles the most general case. *) and codeFunBindings(tlist: fvalbind list, near, context as {decName, mkAddr, level, typeVarMap, lex, ...}) = let (* Get the function variables. *) val functionVars = map (fn(FValBind{functVar = ref var, ...}) => var) tlist (* Check the types for escaped datatypes. *) local fun checkVars(FValBind{functVar=ref var, location, ...}) = checkForEscapingDatatypes(valTypeOf var, fn message => errorNear (lex, true, near, location, message)) in val () = List.app checkVars tlist end (* Each function may result in either one or two functions actually being generated. If a function is not curried it will generate a single function of one argument, but if it is curried (e.g. fun f a b = ...) it will generate two mutually recursive functions. A function fun f a b = X will be translated into val rec f' = fn(a,b) => X and f = fn a => b => f'(a,b) with the second function (f) being inline. This allows the optimiser to replace references to f with all its arguments by f' which avoids building unneccessary closures. *) fun setValueAddress( FValBind{functVar = ref(Value{access=Local{addr, level}, ...}), ...}, ad, lev) = (addr := ad; level := lev) | setValueAddress _ = raise InternalError "setValueAddress" (* Create a list of addresses for the functions. This is the address used for the most general case. Also set the variable addresses. These may be changed for polymorphic functions but will eventually be reset. *) val addressList = List.map (fn _ => mkAddr 2 (* We need two addresses. *)) tlist val () = ListPair.appEq (fn (t, a) => setValueAddress(t, a, level)) (tlist, addressList) (* Get the polymorphic variables for each function. *) local fun getPoly(FValBind{functVar = ref (Value{typeOf, ...}), ...}) = filterTypeVars(getPolyTypeVars(typeOf, mapTypeVars typeVarMap)) in val polyVarList = List.map getPoly tlist end (* Now we can process the function bindings. *) fun loadFunDecs ((fb as FValBind{numOfPatts = ref numOfPats, functVar = ref(Value{name, ...}), clauses, argType = ref aType, resultType = ref resType, location, ...})::otherDecs, polyVars :: otherPolyVars, addr :: otherAddresses) = let (* Make up the function, and if there are several mutually recursive functions, put it in the vector. *) val procName = decName ^ name; val nPolyVars = List.length polyVars (*val _ = print(concat[name, " is ", Int.toString nPolyVars, "-ary\n"])*) (* Check that all the type-vars are in the list. *) (*local fun checkVars tv = case List.find(fn t => sameTv(t, tv)) fdTypeVars of SOME _ => () | NONE => raise InternalError "Type var not found" in val _ = List.app checkVars polyVars end*) (* Produce a list of the size of any tuples or labelled records in the first clause. Tuples in the first clause are passed as separate arguments. We could look at the other clauses and only pass them as separate arguments if each clause contains a tuple. We can treat labelled records exactly like tuples here - we only need to worry about the mapping from labels to tuple offsets when we create the record (getting the order of evaluation right) and in the pattern-matching code (extracting the right fields). We don't have to worry about that here, because all we're doing is untupling and retupling, taking care always to put the values back at exactly the same offset we got them from. *) val tupleSeq : argumentType list list = case clauses of (FValClause{dec= { args, ...}, ...} :: _) => List.map tupleWidth args | _ => raise InternalError "badly formed parse tree"; local fun getResultTuple(FValClause{exp, ...}) = tupleWidth exp val resultTuples = List.foldl(fn(t, [_]) => getResultTuple t | (_, s) => s) [GeneralType] clauses (* If we're debugging we want the result of the function so we don't do this optimisation. *) (* The optimiser also detects functions returning tuples and turns them into containers. That works for local functions but doesn't work if the function is exported e.g. IntInf.divMod. *) val resultTuple = if (getParameter debugTag (debugParams lex)) then [GeneralType] else resultTuples in val resTupleLength = List.length resultTuple (*val _ = resTupleLength = 1 orelse raise InternalError "resTupleLength <> 1"*) (* If there's a single argument return the type of that otherwise if we're tupling the result is general. *) val (resultType, extraArg) = case resultTuple of [one] => (one, 0) | _ => (GeneralType, 1) end (* Count the total number of arguments needed. *) val totalArgs = List.foldl (op +) (extraArg+nPolyVars) (List.map List.length tupleSeq) (* The old test was "totalArgs = 1", but that's not really right, because we could have one genuine arg plus a lot of "()" patterns. We now use the normal inlining mechanism to optimise this (unusual) case too. *) val noInlineFunction = numOfPats = 1 andalso totalArgs = 1 andalso tupleSeq = [[GeneralType]] andalso resultType = GeneralType (* Turn the list of clauses into a match. *) fun clauseToTree(FValClause {dec={ args, ...}, exp, line, breakPoint, ...}) = MatchTree { vars = if numOfPats = 1 then hd args else TupleTree{fields=args, location=line, expType=ref EmptyType}, exp = exp, location = line, argType = ref badType, resType = ref badType, breakPoint = breakPoint } val matches = map clauseToTree clauses (* We arrange for the inner function to be called with the curried arguments in reverse order, but the tupled arguments in the normal order. For example, the ML declaration: fun g a b c = ... gives the order fun g (a, b, c) = ... gives the order fun g (a, b) c (d, e, f) = ... gives the order We want reverse the order of curried arguments to produce better code. (The last curried argument often gets put into the first argument register by the normal calling mechanism, so we try to ensure that it stays there.) We don't reverse the order of tupled arguments because I'm still a bit confused about when a tuple is an argument tuple (reversed?) and when it isn't (not reversed). Just to add to this, if the function is polymorphic we have to add the polymorphic arguments on at the end. *) local (* Create the argument type list. I'm sure this can be combined with the next version of makeArgs but it's all too complicated. *) fun makeArgs(parms, []) = let val polyParms = List.tabulate(nPolyVars, fn _ => GeneralType) val resTupleSize = resTupleLength in if resTupleSize = 1 then parms @ polyParms else parms @ polyParms @ [GeneralType] end | makeArgs(parms, t::ts) = makeArgs (t @ parms, ts) in val argTypes = makeArgs ([], tupleSeq) end local (* This function comprises a new declaration level *) val nArgTypes = List.length argTypes val fnLevel = newLevel level val argList : codetree = if numOfPats = 1 then mkArgTuple(nArgTypes-totalArgs, totalArgs-extraArg-nPolyVars) else let fun makeArgs([], _) = [] | makeArgs(h::t, n) = mkArgTuple(nArgTypes-n-List.length h, List.length h) :: makeArgs(t, n + List.length h) in mkTuple (makeArgs(tupleSeq, extraArg+nPolyVars)) end local val addresses = ref 1 in fun fnMkAddr n = (! addresses) before (addresses := ! addresses + n) end val innerProcName : string = concat ([procName, "(" , Int.toString totalArgs, ")"]); local (* The poly args come after any result tuple. *) val tupleOffset = if resTupleLength = 1 then 0 else 1 val argAddrs = List.tabulate(nPolyVars, fn n => fn l => mkLoadParam(n+nArgTypes-nPolyVars-tupleOffset, l, fnLevel)) val mainTypeVars = ListPair.zipEq(polyVars, argAddrs) (* Also need to add any variables used by other polymorphic functions but not in the existing list. This is only for very unusual cases. *) fun addExtras (fPolyVars, pVarList) = let fun checkPolymorphism(fpVar, pVars) = if isSome(List.find (fn(t, _) => sameTv(t, fpVar)) mainTypeVars) orelse isSome(List.find (fn (t, _) => sameTv(t, fpVar)) pVars) then pVars else (fpVar, fn _ => defaultTypeCode) :: pVars in List.foldl checkPolymorphism pVarList fPolyVars end val extraEntries = List.foldl addExtras [] polyVarList in val typevarArgMap = mainTypeVars @ extraEntries val newTypeVarMap = extendTypeVarMap(typevarArgMap, fnMkAddr, fnLevel, typeVarMap) end val fnContext = context |> repNewLevel(innerProcName, fnMkAddr, fnLevel) |> repTypeVarMap newTypeVarMap (* If we have (mutually) recursive references to polymorphic functions we need to create local versions applied to the polymorphic variables. We only need to consider functions that use the polymorphic variables for this function. If another function uses different variables it can't be called from this one. If it had been called from this any type variables would have been fixed as monotypes or the type variables of this function. Except this is wrong in one case. If one of the recursive calls involves an exception (e.g. f (fn _ => raise Fail "") (or perhaps some other case involving "don't care" polymorphic variables) it is possible to call a function with more polymorphism. *) local fun createApplications(fVal::fVals, addr::addrList, [] :: polyVarList, otherDecs) = ( (* Monomorphic functions. *) setValueAddress(fVal, addr, level); createApplications(fVals, addrList, polyVarList, otherDecs) ) | createApplications( fVal::fVals, addr::addrList, fPolyVars ::polyVarList, otherDecs) = let fun createMatches fpVar = case List.find (fn(t, _) => sameTv(t, fpVar)) typevarArgMap of SOME (_, codeFn) => codeFn fnLevel | NONE => raise InternalError "createMatches: Missing type var" val polyArgs = List.map createMatches fPolyVars val newAddr = fnMkAddr 1 val polyFn = mkLoad(addr, fnLevel, level) (* Set the address to this so if we use this function we pick up this declaration. *) val () = setValueAddress(fVal, newAddr, fnLevel); val newDecs = mkDec(newAddr, mkEval(polyFn, polyArgs)) :: otherDecs in createApplications(fVals, addrList, polyVarList, newDecs) end | createApplications(_, _, _, decs) = decs in val appDecs = if noInlineFunction then [] (* This may be directly recursive. *) else createApplications (tlist, addressList, polyVarList, []) end local (* Function body. The debug state has a "start of function" entry that is used when tracing and points to the arguments. There are then entries for the recursive functions so they can be used if we break within the function. *) fun codeBody fnEntryEnv = let val startContext = fnContext |> repDebugEnv fnEntryEnv (* Create debug entries for recursive references. *) val (recDecs, recDebugEnv) = makeDebugEntries(functionVars, startContext) val bodyContext = fnContext |> repDebugEnv recDebugEnv val codeMatches = mkEnv(recDecs, codeMatch (near, matches, argList, false, bodyContext)) in (* If the result is a tuple we try to avoid creating it by adding an extra argument to the inline function and setting this to the result. *) if resTupleLength = 1 then codeMatches else (* The function sets the extra argument to the result of the body of the function. We use the last argument for the container so that other arguments will be passed in registers in preference. Since the container is used for the result this argument is more likely to have to be pushed onto the stack within the function than an argument which may have its last use early on. *) mkSetContainer(mkLoadParam(nArgTypes-1, fnLevel, fnLevel), codeMatches, resTupleLength) end in (* If we're debugging add the debug info before resetting the level. *) val codeForBody = wrapFunctionInDebug(codeBody, procName, argList, aType, resType, location, fnContext) end val () = if List.length argTypes = totalArgs then () else raise InternalError "Argument length problem" in val innerFun = mkFunction{ body=mkEnv(getCachedTypeValues newTypeVarMap @ appDecs, codeForBody), argTypes=argTypes, resultType=resultType, name=innerProcName, closure=getClosure fnLevel, numLocals=fnMkAddr 0} end; (* We now have a function which can be applied to the arguments once we have them. If the function is curried we must make a set of nested inline procedures which will take one of the parameters at a time. If all the parameters are provided at once they will be optimised away. *) val polyLevel = if null polyVars then level else newLevel level (* Make into curried functions *) fun makeFuns(innerLevel, _, mkParms, []) = let (* Load a reference to the inner function. *) val loadInnerFun = mkLoad (addr + 1, innerLevel, level) val polyParms = List.tabulate(nPolyVars, fn n => (mkLoadParam(n, innerLevel, polyLevel), GeneralType)) val resTupleSize = resTupleLength val parms = mkParms innerLevel in (* Got to the bottom. - put in a call to the procedure. *) if resTupleSize = 1 then (mkCall (loadInnerFun, parms @ polyParms, resultType), 0) else (* Create a container for the result, side-effect it in the function, then create a tuple from it. Most of the time this will be optimised away. *) let val containerAddr = 0 (* In a new space *) val loadContainer = mkLoadLocal containerAddr in (mkEnv( [mkContainer(containerAddr, resTupleSize, mkCall(loadInnerFun, parms @ polyParms @ [(loadContainer, GeneralType)], GeneralType))], mkTupleFromContainer(containerAddr, resTupleSize)), containerAddr+1 (* One local *)) end end | makeFuns(innerLevel, decName, mkParms, t::ts) = let (* Make a function. *) val nLevel = newLevel innerLevel val newDecName : string = decName ^ "(1)" (* Arguments from this tuple precede older arguments, but order of arguments within the tuple is preserved. *) fun nextParms l = loadArgsFromTuple(t, mkLoadParam (0, l, nLevel)) @ mkParms l val (body, lCount) = makeFuns (nLevel, newDecName, nextParms, ts) in (mkInlproc (body, 1, newDecName, getClosure nLevel, lCount), 0) end (* end makeFuns *); (* Reset the address of the variable. *) val () = setValueAddress(fb, addr, level) in if noInlineFunction then (addr, innerFun) :: loadFunDecs(otherDecs, otherPolyVars, otherAddresses) else let val (baseFun, _) = makeFuns (polyLevel, procName, fn _ => [], tupleSeq) val polyFun = if null polyVars then baseFun else mkInlproc(baseFun, List.length polyVars, procName ^ "(P)", getClosure polyLevel, 0) in (* Return the `inner' procedure and the inline functions as a mutually recursive pair. Try putting the inner function first to see if the optimiser does better this way. *) (addr + 1, innerFun) :: (addr, polyFun) :: loadFunDecs(otherDecs, otherPolyVars, otherAddresses) end end (* loadFunDecs *) | loadFunDecs _ = [] val loaded = loadFunDecs(tlist, polyVarList, addressList) (* Set the final addresses in case they have changed. N.B. Do this before loading any debug references. *) val () = ListPair.appEq (fn (t, a) => setValueAddress(t, a, level)) (tlist, addressList) (* Construct the debugging environment for the rest of the scope. *) val (decEnv, newDebugEnv) = makeDebugEntries(functionVars, context) (* Check whether any of the functions were unreferenced. *) val _ = if getParameter reportUnreferencedIdsTag (debugParams lex) then reportUnreferencedValues(functionVars, lex) else () in (* Put the declarations into a package of mutual decs. *) (mkMutualDecs loaded :: decEnv, newDebugEnv) end (* codeFunBindings *) (* Recursive val declarations. Turn them into fun-bindings. This avoids duplicating a lot of code and codeFunBindings does a lot of optimisation. *) and codeRecValBindings(valDecs, near, context) = let (* Turn this into a fun binding. *) fun valBindToFvalBind(ValBind{ exp, line, variables=ref vars, ...}, fVals) = let fun getMatches (Fn { matches: matchtree list, ... }) = matches | getMatches (Constraint {value, ...}) = getMatches value | getMatches (Parenthesised(p, _)) = getMatches p | getMatches _ = raise InternalError "getMatches" fun matchTreeToClause(MatchTree{vars, exp, location, breakPoint, ...}) = let val dec = { ident = { name="", expType=ref EmptyType, location=location}, isInfix = false, args=[vars], constraint=NONE} in FValClause{dec = dec, exp=exp, line=location, breakPoint = breakPoint } end val clauses = List.map matchTreeToClause (getMatches exp) fun mkFValBind(var as Value{typeOf, ...}) = let val argType = mkTypeVar(generalisable, false, false, false) and resultType = mkTypeVar(generalisable, false, false, false) val () = if isSome(unifyTypes(typeOf, mkFunctionType(argType, resultType))) then raise InternalError "mkFValBind" else () in FValBind { clauses=clauses, numOfPatts=ref 1, functVar=ref var, argType=ref argType, resultType=ref resultType, location=line } end in fVals @ List.map mkFValBind vars end val converted = List.foldl valBindToFvalBind [] valDecs in codeFunBindings(converted, near, context) end (* codeRecValBindings *) (* Non-recursive val bindings. *) and codeNonRecValBindings(valBindings, near, originalContext: cgContext as { decName, typeVarMap, lex, isOuterLevel, ...}) = let (* Non-recursive val bindings. *) fun codeBinding (ValBind{dec=vbDec, exp=vbExp, line, variables=ref vars, ...}, otherDecs) = let (* A binding. *) (* Get a name for any functions. This is used for profiling and exception trace. *) val fName = case vars of [] => "_" | _ => String.concatWith "|" (List.map valName vars) (* Does this contain polymorphism? *) val polyVarsForVals = List.map(fn Value{typeOf, ...} => filterTypeVars (getPolyTypeVars(typeOf, mapTypeVars typeVarMap))) vars val polyVars = List.foldl(op @) [] polyVarsForVals val nPolyVars = List.length polyVars (* In almost all cases polymorphic declarations are of the form val a = b or val a = fn ... . They can, though, arise in pathological cases with arbitrary patterns and complex expressions. If any of the variables are polymorphic the expression must have been non-expansive. That means that we can safely evaluate it repeatedly. There's one exception: it may raise Bind. (e.g. val SOME x = NONE). For that reason we make sure it is evaluated at least once. We build the code as a function and then apply it one or more times. This is really to deal with pathological cases and pretty well all of this will be optimised away. *) val localContext as {level, mkAddr, typeVarMap, ...} = if nPolyVars = 0 then originalContext else let val addresses = ref 1 fun fnMkAddr n = (! addresses) before (addresses := ! addresses + n) val fnLevel = newLevel (#level originalContext) val argAddrs = List.tabulate(nPolyVars, fn n => fn l => mkLoadParam(n, l, fnLevel)) val argMap = ListPair.zipEq(polyVars, argAddrs) val newTypeVarMap = extendTypeVarMap(argMap, fnMkAddr, fnLevel, #typeVarMap originalContext) in originalContext |> repNewLevel(decName, fnMkAddr, fnLevel) |> repTypeVarMap newTypeVarMap end val exp = codegen (vbExp, localContext |> repDecName (decName ^ fName ^ "-")) (* Save the argument in a variable. *) val decCode = multipleUses (exp, fn () => mkAddr 1, level) (* Generate the code and also check for redundancy and exhaustiveness. *) local val cmContext = { mkAddr = mkAddr, level = level, typeVarMap = typeVarMap, lex = lex } in val (bindCode, exhaustive) = codeBindingPattern(vbDec, #load decCode level, line, cmContext) end (* Report inexhaustiveness if necessary. *) val () = if not exhaustive andalso not isOuterLevel then errorNear (lex, false, near, line, "Pattern is not exhaustive.") else () (* Check for unreferenced variables. *) val () = if getParameter reportUnreferencedIdsTag (debugParams lex) then List.app (reportUnreferencedValue lex) (getVariablesInPatt(vbDec, [])) else () val resultCode = if nPolyVars = 0 then #dec decCode @ bindCode else let fun loadVal(Value{access=Local{addr=ref add, ...}, ...}) = mkLoadLocal add | loadVal _ = raise InternalError "loadVal" val outerAddrs = #mkAddr originalContext and outerLevel = #level originalContext (* Construct a function that, when applied, returns all the variables. *) val fnAddr = outerAddrs 1 val resFunction = mkDec(fnAddr, mkInlproc( mkEnv(getCachedTypeValues typeVarMap @ #dec decCode @ bindCode, mkTuple(List.map loadVal vars)), nPolyVars, "(P)", getClosure level, mkAddr 0)) (* Apply the general function to the set of type variables using either the actual type variables if they are in this particular variable or defaults if they're not. *) fun application(pVars, level) = let val nPVars = List.length pVars val varNos = ListPair.zipEq(pVars, List.tabulate(nPVars, fn x=>x)) fun getArg argV = case List.find (fn (v, _) => sameTv(v, argV)) varNos of SOME (_, n) => mkLoadParam(n, level, level) | NONE => defaultTypeCode in mkEval(mkLoad(fnAddr, level, outerLevel), List.map getArg polyVars) end (* For each variable construct either a new function if it is polymorphic or a simple value if it is not (e.g. val (a, b) = (fn x=>x, 1)). Set the local addresses at the same time. *) fun loadFunctions(var::vars, polyV::polyVs, n) = let val vAddr = outerAddrs 1 val () = case var of Value{access=Local{addr, level}, ...} => (addr := vAddr; level := outerLevel) | _ => raise InternalError "loadFunctions" in mkDec(vAddr, case polyV of [] => (* monomorphic *) mkInd(n, application([], outerLevel)) | _ => (* polymorphic *) let val nPolyVars = List.length polyV val nLevel = newLevel outerLevel in mkInlproc( mkInd(n, application(polyV, nLevel)), nPolyVars, "(P)", getClosure nLevel, 0) end ) :: loadFunctions(vars, polyVs, n+1) end | loadFunctions _ = [] val loadCode = loadFunctions(vars, polyVarsForVals, 0) in (* Return the declaration of the function, a dummy application that will force any pattern checking and raise a Match if necessary and the declarations of the variables. *) resFunction :: mkNullDec(application([], outerLevel)) :: loadCode end in otherDecs @ resultCode end in List.foldl codeBinding [] valBindings end (* codeNonRecValBindings *) (* Code generates the parse tree. *) fun gencode (pt : parsetree, lex: lexan, debugEnv: debuggerStatus, outerLevel, mkOuterAddresses, outerTypeVarMap, structName: string, continuation) : codeBinding list * debuggerStatus = codeSequence ([(pt, ref NONE)], [], {decName=structName, mkAddr=mkOuterAddresses, level=outerLevel, typeVarMap=outerTypeVarMap, debugEnv=debugEnv, lex=lex, lastDebugLine=ref 0, isOuterLevel = true}, fn (code: codeBinding list, {debugEnv, typeVarMap, ...}) => continuation(code, debugEnv, typeVarMap)) (* Types that can be shared. *) structure Sharing = struct type parsetree = parsetree and lexan = lexan and codetree = codetree and environEntry = environEntry and level = level and typeVarMap = typeVarMap and codeBinding = codeBinding and debuggerStatus = debuggerStatus end end; diff --git a/mlsource/MLCompiler/ParseTree/MATCH_COMPILER.sml b/mlsource/MLCompiler/ParseTree/MATCH_COMPILER.sml index 7d0b685d..93ded43b 100644 --- a/mlsource/MLCompiler/ParseTree/MATCH_COMPILER.sml +++ b/mlsource/MLCompiler/ParseTree/MATCH_COMPILER.sml @@ -1,1202 +1,1199 @@ (* - Copyright (c) 2013, 2015 David C.J. Matthews + Copyright (c) 2013, 2015, 2020 David C.J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) (* Derived from the original parse-tree Copyright (c) 2000 Cambridge University Technical Services Limited - Further development: - Copyright (c) 2000-13 David C.J. Matthews - Title: Parse Tree Structure and Operations. Author: Dave Matthews, Cambridge University Computer Laboratory Copyright Cambridge University 1985 *) functor MATCH_COMPILER ( structure BASEPARSETREE : BaseParseTreeSig structure PRINTTREE: PrintParsetreeSig structure LEX : LEXSIG structure CODETREE : CODETREESIG structure DEBUGGER : DEBUGGER structure TYPETREE : TYPETREESIG structure TYPEIDCODE: TYPEIDCODESIG structure STRUCTVALS : STRUCTVALSIG structure VALUEOPS : VALUEOPSSIG structure DATATYPEREP: DATATYPEREPSIG - structure DEBUG: DEBUGSIG + structure DEBUG: DEBUG structure MISC : sig (* These are handled in the compiler *) exception Conversion of string (* string to int conversion failure *) (* This isn't handled at all (except generically) *) exception InternalError of string (* compiler error *) end structure ADDRESS : AddressSig sharing BASEPARSETREE.Sharing = PRINTTREE.Sharing = LEX.Sharing = CODETREE.Sharing = DEBUGGER.Sharing = TYPETREE.Sharing = TYPEIDCODE.Sharing = STRUCTVALS.Sharing = VALUEOPS.Sharing = DATATYPEREP.Sharing = ADDRESS ): MatchCompilerSig = struct open BASEPARSETREE open PRINTTREE open CODETREE open TYPEIDCODE open LEX open TYPETREE open DEBUG open STRUCTVALS open VALUEOPS open MISC open DATATYPEREP open TypeVarMap datatype environEntry = datatype DEBUGGER.environEntry type debuggerStatus = DEBUGGER.debuggerStatus (* To simplify passing the context it is wrapped up in this type. This is a subset of the context used in CODEGEN_PARSETREE. *) type matchContext = { mkAddr: int->int, level: level, typeVarMap: typeVarMap, lex: lexan } (* Devised by Mike Fourman, Nick Rothwell and me (DCJM). First coded up by Nick Rothwell for the Kit Compiler. First phase of the match compiler. The purpose of this phase is to take a match (a set of patterns) and bring together the elements that will be discriminated by testing any particular part of the value. Where a pattern is a tuple, for example, it is possible to discriminate on each of the fields independently, but it may be more efficient to discriminate on one of the fields first, and then on the others. The aim is to produce a set of tests that discriminate between the patterns quickly. *) abstype patSet = PatSet of int list with (* Each leaf in the tree contains a number which identifies the pattern it came from. As well as linking back to the patterns, these numbers represent an ordering, because earlier patterns mask out later ones. *) (* A set of pattern identifiers. *) val empty = PatSet []; fun singleton i = PatSet [i]; fun list (PatSet p) = p; infix 3 :::; fun a ::: b = PatSet (a :: list b); fun isEmptySet (PatSet []) = true | isEmptySet _ = false fun first (PatSet p) = hd p; fun next (PatSet p) = PatSet (tl p); fun cardinality(PatSet p) = List.length p (* Set from i to j inclusive. *) fun from i j = if i > j then empty else i ::: from (i + 1) j; infix 3 plus; infix 4 inside; infix 5 intersect; infix 6 diff; infix 7 eq; infix 8 eqSc infix 9 neq; (* Union of sets. *) fun a plus b = if isEmptySet a then b else if isEmptySet b then a else if first a = first b then first a ::: (next a plus next b) else if first a < first b then first a ::: (next a plus b) else first b ::: (a plus next b); (* Set membership. *) fun i inside a = if isEmptySet a then false else if i = first a then true else if i < first a then false else i inside next a (* Intersection of sets. *) fun a intersect b = if isEmptySet a orelse isEmptySet b then empty else if first a = first b then first a ::: ((next a) intersect (next b)) else if first a < first b then (next a) intersect b else a intersect next b; (* Set difference. *) fun a diff b = if isEmptySet a then empty else if isEmptySet b then a else if first a = first b then (next a) diff (next b) else if first a < first b then first a ::: ((next a) diff b) else a diff next b; (* Set equality. *) fun (PatSet a) eq (PatSet b) = a = b end (* patSet *); datatype aot = Aot of { patts: aots, (* Choices made at this point. *) defaults: patSet, (* Patterns that do not discriminate on this node. *) vars: values list (* The variables bound at this point. *) } and aots = TupleField of aot list (* Each element of the list is a field of the tuple. *) | Cons of consrec list * int (* List of constructors and the number of different constructors. *) | Excons of exconsrec list (* Exception constructors. *) | Scons of sconsrec list (* Int, char, string, real. *) | Wild (* Patterns that do not discriminate at all. *) (* Datatype constructors and exception constructors. *) withtype consrec = { constructor: values, (* The constructor itself. *) patts: patSet, (* Patterns that use this constructor *) appliedTo: aot, (* Patterns this constructor was applied to. *) polyVars: types list (* If this was polymorphic, the matched types. *) } and exconsrec = { constructor: values, patts: patSet, appliedTo: aot, exValue: machineWord option } and sconsrec = { eqFun: codetree, (* Equality functions for this type*) specVal: machineWord option, (* The constant value. NONE here means we had a conversion error. *) patts: patSet (* Patterns containing this value. *) } fun makeAot(patts, defaults, vars) = Aot { patts = patts, defaults = defaults, vars = vars } fun makeConsrec(constructor, patts, appliedTo, polyVars): consrec = { constructor = constructor, patts = patts, appliedTo = appliedTo, polyVars = polyVars } fun makeExconsrec(constructor, patts, appliedTo, exValue): exconsrec = { constructor = constructor, patts = patts, appliedTo = appliedTo, exValue = exValue } fun makeSconsrec(eqFun, specVal, patts) : sconsrec = { eqFun = eqFun, specVal = specVal, patts = patts } (* An empty wild card - can be expanded as required. *) val aotEmpty = makeAot(Wild, empty, []) (* A new wild card entry with the same defaults as a previous entry. *) fun wild (Aot {defaults, ...}) = makeAot(Wild, defaults, []) local (* Add a default (wild card or variable) to every node in the tree. *) fun addDefault (Aot {patts, defaults, vars}) patNo = let val newPatts = case patts of TupleField pl => TupleField (map (fn a => addDefault a patNo) pl) | Cons(cl, width) => let fun addDefaultToConsrec {constructor, patts, appliedTo, polyVars} = makeConsrec(constructor, patts, addDefault appliedTo patNo, polyVars) in Cons (map addDefaultToConsrec cl, width) end | Excons cl => let fun addDefaultToExconsrec {constructor, patts, appliedTo, exValue} = makeExconsrec(constructor, patts, addDefault appliedTo patNo, exValue) in Excons (map addDefaultToExconsrec cl) end | otherPattern => (* Wild, Scons *) otherPattern in makeAot(newPatts, defaults plus singleton patNo, vars) end (* addDefault *) fun addVar (Aot {patts, defaults, vars}) var = makeAot(patts, defaults, var :: vars) (* Add a constructor to the tree. It can only be added to a cons node or a wild card. *) fun addConstr(cons, noOfConstrs, doArg, tree as Aot {patts = Wild, defaults, vars, ...}, patNo, polyVars) = let (* Expand out the wildCard into a constructor node. *) val cr = makeConsrec(cons, singleton patNo, (* Expand the argument *) doArg (wild tree), polyVars); in makeAot(Cons([cr], noOfConstrs), defaults, vars) end | addConstr(cons, _, doArg, tree as Aot {patts = Cons(pl, width), defaults, vars}, patNo, polyVars) = let (* Merge this constructor with other occurences. *) fun addClist [] = (* Not there - add this on the end. *) [makeConsrec(cons, singleton patNo, doArg (wild tree), polyVars)] | addClist ((ccl as {constructor, patts, appliedTo, ... })::ccls) = if valName constructor = valName cons then (* Merge in. *) makeConsrec(cons, singleton patNo plus patts, doArg appliedTo, polyVars) :: ccls else (* Carry on looking. *) ccl :: addClist ccls; in makeAot (Cons (addClist pl, width), defaults, vars) end | addConstr _ = raise InternalError "addConstr: badly-formed and-or tree" (* Add a special constructor to the tree. Very similar to preceding. *) fun addSconstr(eqFun, cval, Aot {patts = Wild, defaults, vars, ...}, patNo, _) = (* Expand out the wildCard into a constructor node. *) makeAot (Scons [makeSconsrec(eqFun, cval, singleton patNo)], defaults, vars) | addSconstr(eqFun, cval, Aot {patts = Scons pl, defaults, vars, ...}, patNo, lex) = let (* Must be scons *) (* Merge this constructor with other occurrences. *) (* Special constants may be overloaded so we don't have a fixed set of types here. We need to use the type-specific equality function to test. Since only the basis library overloads constants we can assume that eqFun is a constant. *) fun equalSpecials(SOME a, SOME b) = let val eqCode = mkEval(eqFun, [mkTuple[mkConst a, mkConst b]]) in RunCall.unsafeCast(valOf(evalue(genCode(eqCode, debugParams lex, 0)()))) end | equalSpecials _ = false fun addClist [] = (* Not there - add this on the end. *) [makeSconsrec(eqFun, cval, singleton patNo)] | addClist ((ccl as { specVal, patts, ...}) :: ccls) = if equalSpecials(cval, specVal) then (* Merge in. *) makeSconsrec(eqFun, cval, singleton patNo plus patts) :: ccls else (* Carry on looking. *) ccl :: addClist ccls in makeAot (Scons (addClist pl), defaults, vars) end | addSconstr _ = raise InternalError "addSconstr: badly-formed and-or tree" (* Return the exception id if it is a constant. It may be a top-level exception or it could be in a top-level structure. *) local fun testAccess(Global code) = evalue code | testAccess(Selected{addr, base}) = ( case testAccess base of NONE => NONE | SOME c => evalue(mkInd(addr, mkConst c)) ) | testAccess _ = NONE in fun exceptionId(Value{access, ...}) = testAccess access end (* Add an exception constructor to the tree. Similar to the above now that non-constant exceptions are excluded from codePatt. *) fun addExconstr(cons, doArg, tree as Aot {patts = Wild, defaults, vars, ...}, patNo) = (* Expand out the wildCard into a constructor node. *) let val cr = makeExconsrec (cons, singleton patNo, doArg(wild tree), exceptionId cons) in makeAot (Excons [cr], defaults, vars) end | addExconstr(cons, doArg, tree as Aot {patts = Excons cl, defaults, vars, ...}, patNo) = let (* See if this is a constant. *) val newExval = exceptionId cons (* Two exceptions can only be considered the same if they are both constants and the same value. *) fun sameException(SOME a, SOME b) = PolyML.pointerEq(a, b) | sameException _ = false (* It would not be safe to merge exceptions if we were *) fun addClist [] = (* Not there - add this on the end. *) [makeExconsrec(cons, singleton patNo, doArg(wild tree), newExval)] | addClist ((ccl as {constructor, patts, appliedTo, exValue, ... })::ccls) = if sameException(newExval, exValue) then (* Merge in. *) makeExconsrec(constructor, singleton patNo plus patts, doArg appliedTo, exValue) :: ccls else (* Carry on looking. *) ccl :: addClist ccls in makeAot (Excons (addClist cl), defaults, vars) end | addExconstr _ = raise InternalError "addExconstr: badly-formed and-or tree" in (* Take a pattern and merge it into an andOrTree. *) fun buildAot (Ident {value=ref ident, expType=ref expType, ... }, tree, patNo, line, context as { typeVarMap, ...} ) = let val polyVars = List.map #value (getPolymorphism (ident, expType, typeVarMap)) fun doArg a = buildAot(WildCard nullLocation, a, patNo, line, context) in case ident of Value{class=Constructor {ofConstrs, ...}, ...} => (* Only nullary constructors. Constructors with arguments will be dealt with by ``isApplic'. *) addConstr(ident, ofConstrs, doArg, tree, patNo, polyVars) | Value{class=Exception, ...} => addExconstr(ident, doArg, tree, patNo) | _ => (* variable - matches everything. Defaults here and pushes a var. *) addVar (addDefault tree patNo) ident end | buildAot (TupleTree{fields, location, ...}, tree as Aot {patts = Wild, defaults = treeDefaults, vars = treeVars, ...}, patNo, _, context) = (* Adding tuple to existing wild-card *) let val tlist = map (fn el => buildAot(el, wild tree, patNo, location, context)) fields in makeAot (TupleField tlist, treeDefaults, treeVars) end | buildAot (TupleTree{fields, ...}, Aot {patts = TupleField pl, defaults = treeDefaults, vars = treeVars, ...}, patNo, line, context) = let (* Adding tuple to existing tuple. *) (* Merge each field of the tuple in with the corresponding field of the existing tree. *) val tlist = ListPair.mapEq (fn(t, a) => buildAot(t, a, patNo, line, context)) (fields, pl) in makeAot (TupleField tlist, treeDefaults, treeVars) end | buildAot (TupleTree _, _, _, _, _) = raise InternalError "pattern is not a tuple in a-o-t" | buildAot (vars as Labelled {recList, expType=ref expType, location, ...}, tree, patNo, _, context as { lex, ...}) = let (* Treat as a tuple, but in the order of the record entries. Missing entries are replaced by wild-cards. The order of the patterns given may bear no relation to the order in the record which will be matched. e.g. case X of (a = 1, ...) => ___ | (b = 2, a = 3) => ___ *) (* Check that the type is frozen. *) val () = if recordNotFrozen expType then errorNear (lex, true, vars, location, "Can't find a fixed record type.") else () (* Get the maximum number of patterns. *) val wilds = List.tabulate(recordWidth expType, fn _ => WildCard nullLocation) (* Now REPLACE entries from the actual pattern, leaving the defaulting ones behind. *) (* Take a pattern and add it into the list. *) fun mergen (_ :: t) 0 pat = pat :: t | mergen (h :: t) n pat = h :: mergen t (n - 1) pat | mergen [] _ _ = raise InternalError "mergen"; fun enterLabel ({name, valOrPat, ...}, l) = (* Put this label in the appropriate place in the tree. *) mergen l (entryNumber (name, expType)) valOrPat val tupleList = List.foldl enterLabel wilds recList in (* And process it as a tuple. *) buildAot(TupleTree{fields=tupleList, location=location, expType=ref expType}, tree, patNo, location, context) end | buildAot (Applic{f = Ident{value = ref applVal, expType = ref expType, ...}, arg, location, ...}, tree, patNo, _, context as { typeVarMap, ...}) = let val polyVars = List.map #value (getPolymorphism (applVal, expType, typeVarMap)) fun doArg atree = buildAot(arg, atree, patNo, location, context) in case applVal of Value{class=Constructor{ofConstrs, ...}, ...} => addConstr(applVal, ofConstrs, doArg, tree, patNo, polyVars) | Value{class=Exception, ...} => addExconstr(applVal, doArg, tree, patNo) | _ => tree (* Only if error *) end | buildAot (Applic _ , tree, _, _, _) = tree (* Only if error *) | buildAot (Unit _, tree, patNo, _, _) = (* There is only one value so it matches everything. *) addDefault tree patNo | buildAot (WildCard _, tree, patNo, _, _) = addDefault tree patNo (* matches everything *) | buildAot (List{elements, location, expType=ref expType, ...}, tree, patNo, _, context) = let (* Generate suitable combinations of cons and nil. e.g [1,2,3] becomes ::(1, ::(2, ::(3, nil))). *) (* Get the base type. *) val elementType = mkTypeVar (generalisable, false, false, false) val listType = mkTypeConstruction ("list", tsConstr listConstr, [elementType], [DeclaredAt inBasis]) val _ = unifyTypes(listType, expType) val polyVars = [elementType] fun processList [] tree = (* At the end put in a nil constructor. *) addConstr(nilConstructor, 2, fn a => buildAot (WildCard nullLocation, a, patNo, location, context), tree, patNo, polyVars) | processList (h :: t) tree = (* Cons node. *) let fun mkConsPat (Aot {patts = TupleField [hPat, tPat], defaults, vars, ...}) = let (* The argument is a pair consisting of the list element and the rest of the list. *) val tlist = [buildAot(h, hPat, patNo, location, context), processList t tPat]; in makeAot (TupleField tlist, defaults, vars) end | mkConsPat (tree as Aot {patts = Wild, defaults, vars, ...}) = let val hPat = wild tree; val tPat = wild tree; val tlist = [buildAot(h, hPat, patNo, location, context), processList t tPat]; in makeAot (TupleField tlist, defaults, vars) end | mkConsPat _ = raise InternalError "mkConsPat: badly-formed parse-tree" in addConstr(consConstructor, 2, mkConsPat, tree, patNo, polyVars) end (* end processList *); in processList elements tree end | buildAot (vars as Literal{converter, literal, expType=ref expType, location}, tree, patNo, _, {lex, level, ...}) = let (* At the same time we have to get the equality function for this type to plug into the code. Literals are overloaded so this may require first resolving the overload to the preferred type. *) val constr = typeConstrFromOverload(expType, true) val equality = equalityForType( mkTypeConstruction(tcName constr, constr, [], []), level, defaultTypeVarMap(fn _ => raise InternalError "equalityForType", baseLevel) (* Should never be used. *)) val litValue: machineWord option = getLiteralValue(converter, literal, expType, fn s => errorNear(lex, true, vars, location, s)) in addSconstr(equality, litValue, tree, patNo, lex) end | buildAot (Constraint {value, location, ...}, tree, patNo, _, context) = (* process the pattern *) buildAot(value, tree, patNo, location, context) | buildAot (Layered {var, pattern, location}, tree, patNo, _, context) =(* process the pattern *) let (* A layered pattern may involve a constraint which has to be removed. *) fun getVar (Ident {value, ...}) = !value | getVar (Constraint {value, ...}) = getVar value | getVar _ = undefinedValue (* error *) in addVar (buildAot(pattern, tree, patNo, location, context)) (getVar var) end | buildAot (Parenthesised(p, location), tree, patNo, _, context) = buildAot(p, tree, patNo, location, context) | buildAot (_, tree, _, _, _) = tree (* error cases *) end fun buildTree (patts: matchtree list, context) = let (* Merge together all the patterns into a single tree. *) fun maket [] _ tree = tree | maket ((MatchTree{vars, location, ...})::t) patNo tree = maket t (patNo + 1) (buildAot(vars, tree, patNo, location, context)) in maket patts 1 aotEmpty end fun bindPattVars(arg, vars, { mkAddr, level, ...}) = let val addressOfVar = mkAddr 1 val dec = mkDec (addressOfVar, arg) and load = mkLoadLocal addressOfVar (* Set the addresses of the variables and create debug entries. *) fun setAddr (Value{access=Local{addr=lvAddr, level=lvLevel}, ...}) = ( (* Set the address of the variable. *) lvAddr := addressOfVar; lvLevel := level ) | setAddr _ = raise InternalError "setAddr" val () = List.app setAddr vars in (load, dec) end local (* Find the "depth" of pattern i.e. the position of any defaults. If one of the fields is itself a tuple find the maximum depth of its fields, since if we decide to discriminate on this field we will come back and choose the deepest in that tuple. *) fun pattDepth (Aot {patts=TupleField pl, ...}, active) = List.foldl (fn (t, d) => Int.max(pattDepth(t, active), d)) 0 pl | pattDepth (Aot {patts, defaults,...}, active) = let (* Wild cards, constructors etc. *) val activeDefaults = defaults intersect active in if not (isEmptySet activeDefaults) then first activeDefaults else (* No default - the depth is the number of patterns that will be discriminated. Apart from Cons which could be a complete match, all the other cases will only occur if the match is not exhaustive. *) case patts of Cons (cl, _) => length cl + 1 | Excons cl => length cl + 1 | Scons sl => length sl + 1 | _ => 0 (* Error? *) end in fun bestColumn(colsToDo, noOfCols, asTuples, active) = let fun findDeepest(column, bestcol, depth) = if column = noOfCols (* Finished. *) then bestcol else if column inside colsToDo then let val thisDepth = pattDepth (List.nth(asTuples, column), active) in if thisDepth > depth then findDeepest (column + 1, column, thisDepth) else findDeepest (column + 1, bestcol, depth) end else findDeepest (column + 1, bestcol, depth) in findDeepest(0, 0, 0) end end (* The result of compiling the pattern match code. *) datatype pattCodeOption = PattCodeLeaf (* All the discrimination is done. *) | PattCodeBindTuple of (* The value is a tuple - take it apart. *) { tupleNo: int, next: pattCode } | PattCodeTupleSelect of (* Select a field of a tuple. *) { tupleNo: int, fieldOffset: int, next: pattCode } | PattCodeConstructors of (* Test a set of constructors *) { nConstrs: int, (* Number of constrs in datatype. 0 = infinite *) patterns: (pattCodeConstructor * pattCode) list, (* Constructor and pattern to follow. *) default: pattCode (* Pattern if none match *) } | PattCodeNaive of (* Do all the discrimination for each pattern separately. *) { pattNo: int, tests: (naiveTest * values list) list } list and pattCodeConstructor = PattCodeDatatype of values * types list | PattCodeException of values | PattCodeSpecial of codetree * machineWord option and naiveTest = NaiveWild | NaiveBindTuple of int | NaiveTupleSelect of { tupleNo: int, fieldOffset: int } | NaivePattTest of pattCodeConstructor withtype pattCode = { leafSet: patSet, (* Set of different patterns fired by the discrimination. *) leafCount: int, (* Count of number of leaves - >= cardinality of leafSet *) vars: values list, (* Variables bound to this node. May be layered i.e. id as pat *) code: pattCodeOption (* Code to apply at this node. *) } local fun pattCode(Aot {patts, defaults, vars, ...}, active: patSet, nextMatch: patSet * int -> pattCode, tupleNo) = let (* Get the set of defaults which are active. *) val activeDefaults = defaults intersect active fun makePattTest(patts, default, nConstrs) = let (* If we have included all the constructors the default may be redundant. *) val nPatts = length patts val (initSet, initCount) = if nPatts = nConstrs then (empty, 0) else (#leafSet default, #leafCount default) val defaultSet = #leafSet default (* If we have a default above a constructor then we may not need to discriminate on the constructor. This can occur in tuples where we have already discriminated on a different constructor. e.g (1, _) => ...| (_, SOME _) => ... | (_, NONE) => ... The values (1, NONE) and (1, SOME _) will both match the first pattern. *) val allSame = List.all (fn (_, { leafSet, ...}) => leafSet eq defaultSet) patts in if allSame then default else let val unionSet = foldl (fn ((_, {leafSet, ...}), s) => s plus leafSet) initSet patts val leafCount = foldl (fn ((_, {leafCount, ...}), n) => n + leafCount) initCount patts val constrs = { leafSet = unionSet, vars = [], code = PattCodeConstructors{nConstrs = nConstrs, patterns=patts, default=default}, leafCount = leafCount } in (* If the patterns are blowing up we are better off using naive matching. leafCount indicates the number of different times a pattern is fired. The cardinality of the unionSet is the number of different patterns. In particular we can have pathological cases that really blow up. See Tests/Succeed/Test133.ML. *) if leafCount > 1 andalso leafCount >= cardinality unionSet * 2 - 1 then makeNaive constrs else constrs end end val codePatt = (* If the active set is empty (match is not exhaustive) or everything will default we can skip further checks. *) if isEmptySet active orelse active eq activeDefaults then nextMatch(active, tupleNo) else case patts of TupleField [single] => (* Singleton tuple - this is just the same as the field. *) pattCode(single, active, nextMatch, tupleNo) | TupleField asTuples => let val thisTuple = tupleNo (* The address is used to refer to this tuple. *) val nextTupleNo = tupleNo+1 (* A simple-minded scheme would despatch the first column and then do the others. The scheme used here tries to do better by choosing the column that has any wild card furthest down the column. *) val noOfCols = length asTuples fun despatch colsToDo (active, tupleNo) = (* If we have done all the columns we can stop. (Or if the active set is empty). *) if isEmptySet colsToDo orelse isEmptySet active then nextMatch(active, tupleNo) else let (* Choose the best column. *) val bestcol = bestColumn(colsToDo, noOfCols, asTuples, active) (* Discriminate on the constructors in it. *) val code as { leafSet, leafCount, ...} = pattCode(List.nth(asTuples, bestcol), active, despatch (colsToDo diff (singleton bestcol)), tupleNo) (* Code to do the selection. *) val select = PattCodeTupleSelect{tupleNo = thisTuple, fieldOffset = bestcol, next = code } in { leafSet = leafSet, leafCount = leafCount, vars = [], code = select } end val takeApartTuple as { leafSet, leafCount, ...} = despatch (from 0 (noOfCols-1)) (active, nextTupleNo) val code = PattCodeBindTuple { tupleNo=tupleNo, next = takeApartTuple } in { leafSet = leafSet, leafCount = leafCount, vars=[], code=code } end | Cons(cl, width) => let fun doConstr({ patts, constructor, appliedTo, polyVars, ...}, rest) = let (* If this pattern is in the active set we discriminate on it. *) val newActive = patts intersect active in if isEmptySet newActive then (* No point *) rest else let val thenCode = pattCode(appliedTo, newActive plus activeDefaults, nextMatch, tupleNo) in (PattCodeDatatype(constructor, polyVars), thenCode) :: rest end end val pattList = foldl doConstr [] cl in makePattTest(pattList, nextMatch(activeDefaults, tupleNo), width) end | Excons cl => let (* We now process exception constructors in the same way as datatype constructors. This is only valid because all the exception constructors are constants. *) fun doConstr({ patts, constructor, appliedTo, ...}, rest) = let (* If this pattern is in the active set we discriminate on it. *) val newActive = patts intersect active in if isEmptySet newActive then (* No point *) rest else let val thenCode = pattCode(appliedTo, newActive plus activeDefaults, nextMatch, tupleNo) in (PattCodeException constructor, thenCode) :: rest end end val pattList = foldl doConstr [] cl in makePattTest(pattList, nextMatch(activeDefaults, tupleNo), 0) end | Scons sl => let (* Int, char, string *) (* Generate if..then..else for each of the choices. *) fun doConstr({ patts, eqFun, specVal, ...}, rest) = let val newActive = patts intersect active in if isEmptySet newActive then (* No point *) rest else (PattCodeSpecial(eqFun, specVal), nextMatch(newActive plus activeDefaults, tupleNo)) :: rest end val pattList = foldl doConstr [] sl in makePattTest(pattList, nextMatch(activeDefaults, tupleNo), 0) end | Wild => nextMatch(activeDefaults, tupleNo) in { leafSet = #leafSet codePatt, leafCount = #leafCount codePatt, vars=vars @ #vars codePatt, code = #code codePatt } end (* Turn a decision tree into a series of tests for each pattern. *) and makeNaive(pattern as { leafSet, vars, ... }) = let fun createTests(_, { code = PattCodeLeaf, vars, ...}) = [(NaiveWild, vars)] | createTests(pat, { code = PattCodeBindTuple{ tupleNo, next }, vars, ... }) = (NaiveBindTuple tupleNo, vars) :: createTests(pat, next) | createTests(pat, { code = PattCodeTupleSelect { tupleNo, fieldOffset, next }, vars, ...}) = (NaiveTupleSelect { tupleNo = tupleNo, fieldOffset = fieldOffset }, vars) :: createTests(pat, next) | createTests(pat, { code = PattCodeConstructors { patterns, default, ... }, vars, ...}) = if pat inside #leafSet default (* If it's in the default set we don't discriminate here. *) then (NaiveWild, vars) :: createTests(pat, default) else let (* If it's not in the default it must be in one of the constructors. *) val (constr, code) = valOf(List.find(fn (_, {leafSet, ...}) => pat inside leafSet) patterns) in (NaivePattTest constr, vars) :: createTests(pat, code) end | createTests(pat, { code = PattCodeNaive l, vars, ...}) = let val { tests, ...} = valOf(List.find(fn{pattNo, ...} => pat = pattNo) l) in (NaiveWild, vars) :: tests end fun createPatts setToDo = if isEmptySet setToDo then [] else let val pat = first setToDo val entry = { pattNo = pat, tests = createTests(pat, pattern) } val otherPatts = createPatts(setToDo diff singleton pat) in (* Normally we want the patterns in order since earlier ones will generally be more specific. If 0 is in the set it represents "non-exhaustive" and must go last. *) if pat = 0 then otherPatts @ [entry] else entry :: otherPatts end in { leafSet=leafSet, vars=vars, code=PattCodeNaive(createPatts leafSet), leafCount = cardinality leafSet } end in fun buildPatternCode(tree, noOfPats, alwaysNaive) = let fun firePatt(pattsLeft, _) = let val pattern = if isEmptySet pattsLeft then 0 (* This represents non-exhaustive. *) else first pattsLeft in { vars = [], code = PattCodeLeaf, leafSet = singleton pattern, leafCount = 1 } end val patts = pattCode(tree, from 1 noOfPats, firePatt, 0) in if alwaysNaive then makeNaive patts else patts end end local val EXC_Bind = 100 val EXC_Match = 101 (* Raises an exception. *) fun raiseException(exName, exIden, line) = mkRaise (mkTuple [exIden, mkStr exName, CodeZero, codeLocation line]); (* Create exception values - Small integer values are used for run-time system exceptions. *) val bindExceptionVal = mkConst (ADDRESS.toMachineWord EXC_Bind); val matchExceptionVal = mkConst (ADDRESS.toMachineWord EXC_Match); in (* Raise match and bind exceptions. *) fun raiseBindException line = raiseException("Bind", bindExceptionVal, line) and raiseMatchException line = raiseException("Match", matchExceptionVal, line) end (* Turn the decision tree into real code. *) local (* Guard and inversion code for constructors *) fun constructorCode(PattCodeDatatype(cons, polyVars), arg, {level, typeVarMap, ...}) = ( makeGuard (cons, polyVars, arg, level, typeVarMap), makeInverse (cons, polyVars, arg, level, typeVarMap) ) | constructorCode(PattCodeException cons, arg, {level, typeVarMap, ...}) = ( makeGuard (cons, [], arg, level, typeVarMap), makeInverse (cons, [], arg, level, typeVarMap) ) | constructorCode(PattCodeSpecial(eqFun, cval), arg, _) = let val constVal = case cval of SOME cv => mkConst cv | NONE => CodeZero in (mkEval(eqFun, [mkTuple[arg, constVal]]), CodeZero (* Unused *)) end (* Sequence of tests for naive match. *) fun makeNaiveTests([], _, _, _) = CodeTrue | makeNaiveTests ((NaiveWild, _) :: rest, arg, tupleMap, context) = makeNaiveTests(rest, arg, tupleMap, context) | makeNaiveTests ((NaiveBindTuple tupleNo, _) :: rest, arg, tupleMap, context) = let (* Bind it to a variable. We don't set the addresses of the vars at this point. *) val (declLoad, declDec) = bindPattVars(arg, [], context) in mkEnv([declDec], makeNaiveTests(rest, arg, (tupleNo, declLoad) :: tupleMap, context)) end | makeNaiveTests ((NaiveTupleSelect { tupleNo, fieldOffset}, _) :: rest, _, tupleMap, context) = let val findTuple = List.find(fn(a, _) => tupleNo = a) tupleMap in makeNaiveTests(rest, mkInd(fieldOffset, #2 (valOf findTuple)), tupleMap, context) end | makeNaiveTests ((NaivePattTest constr, _) :: rest, arg, tupleMap, context) = let (* Bind it to a variable. This avoids making multiple copies of code. *) val (declLoad, declDec) = bindPattVars(arg, [], context) val (thisTest, inverse) = constructorCode(constr, declLoad, context) in mkEnv([declDec], mkCand(thisTest, makeNaiveTests(rest, inverse, tupleMap, context))) end (* Load all the variables. *) fun makeLoads([], _, _, _, _) = [] | makeLoads((pattern, vars) :: rest, patNo, arg, tupleMap, context) = let val (declLoad, declDec) = bindPattVars(arg, vars, context) val pattLoad = case pattern of NaiveWild => makeLoads(rest, patNo, declLoad, tupleMap, context) | NaiveBindTuple tupleNo => makeLoads(rest, patNo, declLoad, (tupleNo, declLoad) :: tupleMap, context) | NaiveTupleSelect { tupleNo, fieldOffset} => let val findTuple = List.find(fn(a, _) => tupleNo = a) tupleMap in makeLoads(rest, patNo, mkInd(fieldOffset, #2 (valOf findTuple)), tupleMap, context) end | NaivePattTest constr => let val (_, inverse) = constructorCode(constr, declLoad, context) in makeLoads(rest, patNo, inverse, tupleMap, context) end in declDec :: pattLoad end in fun codeGenerateMatch(patCode, arg, firePatt, context: matchContext as {level, typeVarMap, ...}) = let fun codeMatch({ leafSet, vars, code, ...}, arg, tupleMap) = let (* Bind the current value to a codetree variable and set the addresses of any ML variables to this. *) val (declLoad, declDec) = bindPattVars(arg, vars, context) val pattCode = case code of PattCodeLeaf => (* Finished - fire the pattern. *) firePatt(first leafSet) | PattCodeBindTuple { tupleNo, next }=> (* Bind the tuple number to this address. *) codeMatch(next, arg, (tupleNo, declLoad) :: tupleMap) | PattCodeTupleSelect { tupleNo, fieldOffset, next } => let (* The tuple number should be in the map. Find the address and select the field. *) val findTuple = List.find(fn(a, _) => tupleNo = a) tupleMap in codeMatch(next, mkInd(fieldOffset, #2 (valOf findTuple)), tupleMap) end | PattCodeConstructors { nConstrs, patterns, default } => let fun doPattern((PattCodeDatatype(cons, polyVars), code) :: rest, 1) = (* This is the last pattern and we have done all the others. We don't need to test this one and we don't use the default. *) let val _ = null rest orelse raise InternalError "doPattern: not at end" val invertCode = makeInverse (cons, polyVars, declLoad, level, typeVarMap) in codeMatch(code, invertCode, tupleMap) end | doPattern([], _) = (* We've done all of them - do the default *) codeMatch(default, arg, tupleMap) | doPattern((constructor, matchCode) :: next, constrsLeft) = let val (testCode, invertCode) = constructorCode(constructor, declLoad, context) val thenCode = codeMatch(matchCode, invertCode, tupleMap) in mkIf(testCode, thenCode, doPattern(next, constrsLeft-1)) end in doPattern(patterns, nConstrs) end | PattCodeNaive patterns => let fun makePatterns [] = raise InternalError "makeTests: empty" | makePatterns ({ tests, pattNo} :: rest) = let val pattDecs = makeLoads(tests, pattNo, arg, tupleMap, context) val pattCode = mkEnv(pattDecs, firePatt pattNo) in (* If this is the last one there's no need for a test. *) if null rest then pattCode else mkIf(makeNaiveTests(tests, arg, tupleMap, context), pattCode, makePatterns rest) end in makePatterns patterns end in mkEnv([declDec], pattCode) end in codeMatch(patCode, arg, []) end (* Binding. This should be a single naive match. Generally it will be exhaustive so we will only have to load the variables. *) fun codeBinding( { leafSet, vars, code = PattCodeNaive({ tests, ...} :: _ (* Normally nil but could be PattCodeWild if non-exhaustive *)), ...}, arg, line, context) = let (* Bind this to a variable and set any top-level variable(s). *) val (declLoad, declDec) = bindPattVars(arg, vars, context) (* Create any test code to raise the bind exception *) val testCode = if not (0 inside leafSet) then [] (* Exhaustive - no test needed. *) else [mkNullDec(mkIf(makeNaiveTests(tests, declLoad, [], context), CodeZero, raiseBindException line))] (* Load the variables. *) val pattDecs = makeLoads(tests, 1, declLoad, [], context) in declDec :: testCode @ pattDecs end | codeBinding _ = raise InternalError "codeBinding: should be naive pattern match" end fun containsNonConstException(Aot{patts = TupleField fields, ...}) = List.foldl(fn (aot, t) => t orelse containsNonConstException aot) false fields | containsNonConstException(Aot{patts = Cons(cl, _), ...}) = List.foldl(fn ({appliedTo, ...}, t) => t orelse containsNonConstException appliedTo) false cl | containsNonConstException(Aot{patts = Excons cl, ...}) = List.foldl(fn ({appliedTo, exValue, ...}, t) => t orelse not (isSome exValue) orelse containsNonConstException appliedTo) false cl | containsNonConstException _ = false (* Scons or Wild *) (* Process a pattern in a binding. *) (* This previously used codePatt with special options to generate the correct structure for a binding. This does the test separately from loading the variables. If the pattern is not exhaustive this may do more work since the pattern is taken apart both in the test and for loading. *) fun codeBindingPattern(vbDec, arg, line, context) = let (* Build the tree. *) val andortree = buildAot(vbDec, aotEmpty, 1, line, context) (* Build the pattern code *) val patternCode as { leafSet, ... } = buildPatternCode(andortree, 1, true (* Always *)) (* It's not exhaustive if pattern zero is in the set. *) val exhaustive = not (0 inside leafSet) val codeDecs = codeBinding(patternCode, arg, line, context) in (codeDecs, exhaustive) end (* Process a set of patterns in a match. *) (* Naive match code. Doesn't check for exhaustiveness or redundancy. *) fun codeMatchPatterns(alt, arg, isHandlerMatch, lineNo, codePatternExpression, context as { lex, ...}) = let val noOfPats = length alt val andortree = buildTree(alt, context) (* If the match is sparse or there are any non-constant exceptions we need to use pattern-by-pattern matching. Non-constant exceptions could involve exception aliasing and this complicates pattern matching. It could break the rule that says that if a value matches one constructor it cannot then match any other. If we are compiling with debugging we also use the naive match. *) val alwaysNaive = containsNonConstException andortree orelse getParameter debugTag (debugParams lex) val patternCode as { leafSet, ... } = buildPatternCode(andortree, noOfPats, alwaysNaive) (* It's not exhaustive if pattern zero is in the set. *) val exhaustive = not (0 inside leafSet) fun firePatt 0 = ( exhaustive andalso raise InternalError "codeDefault called but exhaustive"; if isHandlerMatch then mkRaise arg else raiseMatchException lineNo ) | firePatt pattChosen = codePatternExpression(pattChosen - 1) in (codeGenerateMatch(patternCode, arg, firePatt, context), exhaustive) end (* Types that can be shared. *) structure Sharing = struct type parsetree = parsetree type typeVarMap = typeVarMap type level = level type codetree = codetree type matchtree = matchtree type codeBinding = codeBinding type lexan = lexan end end; diff --git a/mlsource/MLCompiler/SIGNATURES.sml b/mlsource/MLCompiler/SIGNATURES.sml index 335d8e47..c7a5af2e 100644 --- a/mlsource/MLCompiler/SIGNATURES.sml +++ b/mlsource/MLCompiler/SIGNATURES.sml @@ -1,1422 +1,1422 @@ (* Copyright David C. J. Matthews 2009 Largely extracted from STRUCTURES_.ML Copyright (c) 2000 Cambridge University Technical Services Limited - Modified D.C.J. Matthews 2001-2015 + Modified D.C.J. Matthews 2001-2015, 2020 This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) (* Title: Module Structure and Operations. Author: Dave Matthews, Cambridge University Computer Laboratory Copyright Cambridge University 1985 *) functor SIGNATURES ( structure LEX : LEXSIG structure STRUCTVALS : STRUCTVALSIG; structure EXPORTTREE: EXPORTTREESIG structure PRETTY : PRETTYSIG structure COPIER: COPIERSIG structure TYPETREE : TYPETREESIG structure PARSETREE : PARSETREESIG structure VALUEOPS : VALUEOPSSIG; structure UNIVERSALTABLE: sig type universal = Universal.universal type univTable type 'a tag = 'a Universal.tag val univEnter: univTable * 'a tag * string * 'a -> unit; val univLookup: univTable * 'a tag * string -> 'a option; val univFold: univTable * (string * universal * 'a -> 'a) * 'a -> 'a; end; - structure DEBUG: DEBUGSIG + structure DEBUG: DEBUG structure UTILITIES : sig val noDuplicates: (string * 'a * 'a -> unit) -> { apply: (string * 'a -> unit) -> unit, enter: string * 'a -> unit, lookup: string -> 'a option }; val searchList: unit -> { apply: (string * 'a -> unit) -> unit, enter: string * 'a -> unit, lookup: string -> 'a option }; end; sharing LEX.Sharing = TYPETREE.Sharing = PARSETREE.Sharing = PRETTY.Sharing = EXPORTTREE.Sharing = STRUCTVALS.Sharing = COPIER.Sharing = VALUEOPS.Sharing = UNIVERSALTABLE ) : SIGNATURESSIG = struct open Misc (* Open this first because it contains Value. *) open LEX STRUCTVALS EXPORTTREE PRETTY COPIER TYPETREE PARSETREE UNIVERSALTABLE DEBUG open VALUEOPS UTILITIES Universal datatype sigs = SignatureIdent of string * location * locationProp list ref (* A signature name *) | SigDec of specs list * location (* sig ... end *) | WhereType of whereTypeStruct (* type realisation. *) and specs = StructureSig of structSigBind list * location | ValSig of (* Signature of a value. *) { name: string * location, typeof: typeParsetree, line: location } | ExSig of (* Signature of an exception. May be a nullary exception. *) { name: string * location, typeof: typeParsetree option, line: location } | CoreType of (* Any other decln. *) { dec: parsetree, (* The value *) location: location } | Sharing of shareConstraint (* Sharing constraints. *) | IncludeSig of sigs list * location (* Include. *) withtype shareConstraint = { isType: bool, shares: (string * location) list, line: location } and structSigBind = { name: string, (* The name of the structure *) nameLoc: location, sigStruct: sigs * bool * location, line: location } and whereTypeStruct = { sigExp: sigs, typeVars: typeVarForm list, typeName: string, realisation: typeParsetree, line: location } fun mkSigIdent(name, nameLoc) = SignatureIdent(name, nameLoc, ref []) fun mkCoreType (dec, location) = CoreType { dec = dec, location = location }; fun mkValSig (nameLoc, typeof, line) = ValSig { name = nameLoc, typeof = typeof, line = line }; fun mkExSig (nameLoc, typeof, line) = ExSig { name = nameLoc, typeof = typeof, line = line }; fun mkSharing (isType, shares, line) = Sharing { isType = isType, shares = shares, line = line }; fun mkWhereType (sigexp, typeVars, name, types, line) = WhereType { sigExp = sigexp, typeVars = typeVars, typeName = name, realisation = types, line = line }; val mkInclude = IncludeSig and mkStructureSig = StructureSig and mkSig = SigDec fun mkStructureSigBinding ((name, nameLoc), signat, fullLoc):structSigBind = { name = name, nameLoc = nameLoc, sigStruct = signat, line = fullLoc } (* Make a signature for initialisating variables and for undeclared signature variables. *) val undefinedSignature = makeSignature("", makeSignatureTable(), 0, [], fn _ => raise Subscript, []); (* We use a name that isn't otherwise valid for a signature. *) fun isUndefinedSignature(Signatures{name, ...}) = name = "" fun displayList ([], _, _) _ = [] | displayList ([v], _, depth) dodisplay = if depth <= 0 then [PrettyString "..."] else [dodisplay (v, depth)] | displayList (v::vs, separator, depth) dodisplay = if depth <= 0 then [PrettyString "..."] else let val brk = if separator = "," orelse separator = ";" then 0 else 1 in PrettyBlock (0, false, [], [ dodisplay (v, depth), PrettyBreak (brk, 0), PrettyString separator ] ) :: PrettyBreak (1, 0) :: displayList (vs, separator, depth - 1) dodisplay end (* displayList *) fun displaySigs (str, depth) = if depth <= 0 (* elide further text. *) then PrettyString "..." else case str of SignatureIdent (name : string, _, _) => PrettyString name | SigDec (structList : specs list, _) => PrettyBlock (0, true, [], PrettyString "sig" :: PrettyBreak (1, 0) :: displayList (structList, "", depth) displaySpecs @ [ PrettyBreak (1, 0), PrettyString "end"] ) | WhereType { sigExp, typeVars, typeName, realisation, ... } => PrettyBlock (3, false, [], displaySigs (sigExp, depth) :: PrettyBreak (1, 0) :: PrettyString "where" :: PrettyBreak (1, 0) :: PrettyString "type" :: PrettyBreak (1, 0) :: displayTypeVariables (typeVars, depth) @ [ PrettyString typeName, PrettyBreak (1, 0), PrettyString "=", PrettyBreak (1, 0), displayTypeParse (realisation, depth - 1, emptyTypeEnv) ] ) and displaySpecs (specs, depth) = if depth <= 0 (* elide further text. *) then PrettyString "..." else case specs of StructureSig (structList : structSigBind list, _) => let fun displaySigsBind ( {name, sigStruct=(sigStruct, opaque, _), ...}: structSigBind, depth) = PrettyBlock (3, false, [], [ PrettyString name, PrettyString (if opaque then " :>" else " :"), PrettyBreak (1, 0), displaySigs (sigStruct, depth - 1) ] ) in PrettyBlock (3, false, [], PrettyString "structure" :: PrettyBreak (1, 0) :: displayList (structList, "and", depth) displaySigsBind ) end | ValSig {name = (name, _), typeof, ...} => PrettyBlock (0, false, [], [ PrettyString "val", PrettyBreak (1, 1), PrettyString (name ^ " :"), PrettyBreak (1, 0), displayTypeParse (typeof, depth - 1, emptyTypeEnv) ] ) | ExSig {name = (name, _), typeof = NONE, ...} => PrettyBlock (0, false, [], [ PrettyString "exception", PrettyBreak (1, 1), PrettyString (name) ] ) | ExSig {name = (name, _), typeof = SOME typeof, ...} => PrettyBlock (0, false, [], [ PrettyString "exception", PrettyBreak (1, 1), PrettyString (name ^ " :"), PrettyBreak (1, 0), displayTypeParse (typeof, depth - 1, emptyTypeEnv) ] ) | Sharing { isType, shares, ... } => PrettyBlock (3, false, [], PrettyString "sharing" :: PrettyBreak (1, 0) :: ( if not isType then [] else [ PrettyString "type", PrettyBreak (1, 0) ] ) @ displayList (shares, "=", depth) (fn ((name, _), _) => PrettyString name) ) | IncludeSig (structList : sigs list, _) => PrettyBlock (3, true, [], PrettyString "include" :: PrettyBreak (1, 0) :: displayList (structList, "", depth - 1) displaySigs ) | CoreType {dec, ...} => displayParsetree (dec, depth - 1) (* End displaySigs *) fun sigExportTree(navigation, s: sigs) = let (* Common properties for navigation and printing. *) val commonProps = PTprint(fn d => displaySigs(s, d)) :: exportNavigationProps navigation fun asParent () = sigExportTree(navigation, s) in case s of SignatureIdent(_, loc, ref decLocs) => (loc, mapLocationProps decLocs @ commonProps) | SigDec(structList, location) => (location, exportList(specExportTree, SOME asParent) structList @ commonProps) | WhereType _ => (nullLocation, commonProps) end and specExportTree(navigation, s: specs) = let (* Common properties for navigation and printing. *) val commonProps = PTprint(fn d => displaySpecs(s, d)) :: exportNavigationProps navigation fun asParent () = specExportTree(navigation, s) in case s of StructureSig(sbl, location) => let fun exportSB(navigation, sb as {name, nameLoc, sigStruct=(theSig, _, _), line, ...}) = let fun exportThis () = exportSB(navigation, sb) fun getName () = getStringAsTree({parent=SOME exportThis, previous=NONE, next=SOME getSigStruct}, name, nameLoc, []) and getSigStruct () = sigExportTree({parent=SOME exportThis, previous=SOME getName, next=NONE}, theSig) in (line, PTfirstChild getName :: exportNavigationProps navigation) end val expChild = exportList(exportSB, SOME asParent) sbl in (location, expChild @ commonProps) end | ValSig{name=(name, nameLoc), typeof, line, ...} => let (* The first position is the value name, the second the type. *) (* TODO: Include the actual type as PTtype? *) fun getName () = getStringAsTree({parent=SOME asParent, previous=NONE, next=SOME getType}, name, nameLoc, []) and getType () = typeExportTree({parent=SOME asParent, previous=SOME getName, next=NONE}, typeof) in (line, PTfirstChild getName :: commonProps) end | ExSig{name=(name, nameLoc), typeof = NONE, line, ...} => let (* The first position is the value name, the second the type. *) fun getName () = getStringAsTree({parent=SOME asParent, previous=NONE, next=NONE}, name, nameLoc, []) in (line, PTfirstChild getName :: commonProps) end | ExSig{name=(name, nameLoc), typeof = SOME typeof, line, ...} => let (* The first position is the value name, the second the type. *) (* TODO: Include the actual type as PTtype? *) fun getName () = getStringAsTree({parent=SOME asParent, previous=NONE, next=SOME getType}, name, nameLoc, []) and getType () = typeExportTree({parent=SOME asParent, previous=SOME getName, next=NONE}, typeof) in (line, PTfirstChild getName :: commonProps) end | CoreType {dec, ...} => (* A value parse-tree entry. *) getExportTree(navigation, dec) | Sharing _ => (nullLocation, commonProps) | IncludeSig (sigs, loc) => (loc, exportList(sigExportTree, SOME asParent) sigs @ commonProps) end (* Puts out an error message and then prints the piece of tree. *) fun errorMsgNear (lex, hard, near, lno, message) : unit = let val parameters = debugParams lex val errorDepth = getParameter errorDepthTag parameters in reportError lex { hard = hard, location = lno, message = message, context = SOME(near errorDepth) } end fun errorNear(lex, hard, near, lno, message: string) = errorMsgNear (lex, hard, near, lno, PrettyBlock (0, false, [], [PrettyString message])) fun giveError (sVal : sigs, lno : LEX.location, lex : lexan) : string -> unit = fn (message : string) => errorNear (lex, true, fn n => displaySigs(sVal, n), lno, message) and giveSpecError(sVal : specs, lno : LEX.location, lex : lexan) : string -> unit = fn (message : string) => errorNear (lex, true, fn n => displaySpecs(sVal, n), lno, message); val makeEnv = fn x => let val Env e = makeEnv x in e end; fun printId(TypeId{description, ...}) = printDesc description and printDesc{ location: location, name: string, description = "" } = PrettyBlock(0, false, [ContextLocation location], [PrettyString name]) | printDesc{ location: location, name: string, description: string } = PrettyBlock(0, false, [ContextLocation location], [PrettyString name, PrettyBreak(1, 0), PrettyString ("(*" ^ description ^ "*)")]) (* Formal paramater to a functor - either value or exception. *) fun mkFormal (name : string, class, typ, addr, locations) = Value{class=class, name=name, typeOf=typ, access=Formal addr, locations=locations, references = NONE, instanceTypes=NONE} (* Get the value from a signature-returning expression (either the name of a signature or sig ... end. The type IDs in the signature are bound names. *) fun sigVal(str : sigs, initTypeId : int, outerTypeIdEnv: int->typeId, Env globalEnv : env, lex, lno : LEX.location ) : signatures = let datatype varId = SharedWith of int (* Index of shared ID, always less than current index. *) | VariableSlot of { boundId: typeId, descriptions: string list } | FreeSlot of typeId (* Bound to a Free type ID. *) | Unset val idCount = ref initTypeId val mapArray = StretchArray.stretchArray(10 (* Guess initial size. *), Unset) val sourceArray = StretchArray.stretchArray(10 (* Guess initial size. *), NONE) fun makeVariableId(arity, isEq, isDt, requireUpdate, { location, name, description }, structPath) = let val fullName = structPath^name val descr = { location=location, name=fullName, description=description} (* Make a new bound ID after any existing ones. *) val newIdNumber = !idCount before (idCount := !idCount+1) val newId = (if requireUpdate then makeBoundIdWithEqUpdate else makeBoundId) (arity, Formal 0 (* Not used. *), newIdNumber, isEq, isDt, descr) (* Enter a variable entry in the array. *) val arrayEntry = VariableSlot{ boundId=newId, descriptions = [fullName] } val () = StretchArray.update(mapArray, newIdNumber-initTypeId, arrayEntry) val () = StretchArray.update(sourceArray, newIdNumber-initTypeId, SOME newId) in newId end (* Follow a chain of shared IDs. This should terminate because we always point down the array. *) fun realId n = case StretchArray.sub(mapArray, n) of SharedWith m => if m >= n then raise InternalError "realId: Sharing loop" else realId m | id => id fun isVariableId(TypeId{idKind=Bound{offset, ...}, ...}) = if offset < initTypeId then false (* Outside the signature. *) else ( case realId(offset-initTypeId) of VariableSlot _ => true | FreeSlot _ => false | _ => raise InternalError "isVar" ) | isVariableId _ (* Free or TypeFunction *) = false (* The internal type ID map after mapping to the internal Bound IDs but before the application of any "where types" or sharing. *) fun typeIdEnv () = let val v = Vector.tabulate(!idCount-initTypeId, fn n => valOf(StretchArray.sub(sourceArray, n))) in fn n => if n < initTypeId then outerTypeIdEnv n else Vector.sub(v, n-initTypeId) end fun linkFlexibleTypeIds(typeId1, typeId2) = (* Link together and share two IDs. The result is an equality type if either was an equality type and a datatype if either was a datatype. *) case (typeId1, typeId2) of (TypeId{idKind=Bound{offset=offset1, ...}, ...}, TypeId{idKind=Bound{offset=offset2, ...}, ...}) => ( case (realId(offset1-initTypeId), realId(offset2-initTypeId)) of (VariableSlot{descriptions = desc1, boundId=TypeId{ idKind=Bound{eqType=eqType1, offset=off1, isDatatype=isDatatype1, arity=arity1, ...}, description, ...}}, VariableSlot{descriptions = desc2, boundId=TypeId{ idKind=Bound{eqType=eqType2, offset=off2, isDatatype=isDatatype2, arity=arity2, ...}, ...}}) => if off1 = off2 then () (* They may already share. *) else let val resOffset = Int.min(off1, off2) val setOffset = Int.max(off1, off2) val isDatatype = isDatatype1 orelse isDatatype2 val _ = arity1 = arity2 orelse raise InternalError "linkFlexibleTypeIds: different arities" val newId = makeBoundId(arity1, Formal 0, resOffset, pling eqType1 orelse pling eqType2, isDatatype, description (* Not used *)) val newEntry = VariableSlot{ boundId=newId, descriptions = desc1 @ desc2 } in StretchArray.update(mapArray, resOffset-initTypeId, newEntry); StretchArray.update(mapArray, setOffset-initTypeId, SharedWith(resOffset-initTypeId)) end | _ => raise InternalError "linkFlexibleTypeIds: not variable" ) | _ => raise InternalError "linkFlexibleTypeIds: not bound" local (* Sharing *) fun shareTypes(typeA as TypeConstrSet(constrA, _), aPath, aMap, typeB as TypeConstrSet(constrB, _), bPath, bMap, lno, nearStruct) = let fun cantShare reason = let fun showTypeCons(TypeConstrSet(t, _), p) = let val context = case List.find(fn DeclaredAt _ => true | _ => false) (tcLocations t) of SOME(DeclaredAt loc) => [ContextLocation loc] | _ => [] in PrettyBlock(0, false, context, [PrettyString(p ^ tcName t)]) end in errorMsgNear (lex, true, fn n => displaySigs(nearStruct, n), lno, PrettyBlock(3, false, [], [ PrettyString "Cannot share type", PrettyBreak(1, 2), showTypeCons(typeA, aPath), PrettyBreak(1, 0), PrettyString "with type", PrettyBreak(1, 0), showTypeCons(typeB, bPath), PrettyBreak(0, 0), PrettyString ".", PrettyBreak(1, 0), reason ])) end fun alreadyBound(path, typeName, tcId) = cantShare ( PrettyBlock(3, false, [], [ PrettyString(path ^ typeName), PrettyBreak(1, 0), PrettyString "is already defined as", PrettyBreak(1, 0), printId tcId ])) in if isUndefinedTypeConstr constrA orelse isUndefinedTypeConstr constrB then () else if tcArity constrA <> tcArity constrB (* Check arity. *) then cantShare(PrettyString "The type constructors take different numbers of arguments.") else let fun mapId (map, TypeId{idKind=Bound{offset, ...}, ...}) = map offset | mapId (_, id) = id val aId = mapId(aMap, tcIdentifier constrA) and bId = mapId(bMap, tcIdentifier constrB) in (* The type constructors are only looked up in the signature but they already may be set to another type through a "where type" or they may have been created with Free IDs through type t=s declarations. This could be a free identifier or a type function. *) if not (isVariableId aId) then alreadyBound(aPath, tcName constrA, aId) else if not (isVariableId bId) then alreadyBound(bPath, tcName constrB, bId) else linkFlexibleTypeIds(aId, bId) end end (* shareTypes *); (* Find all the structures and type constructors in one structure. *) fun structsAndTypes((Struct{signat=Signatures { tab, typeIdMap, ... }, ...}, path, oldMap), start) = let val newMap = composeMaps(typeIdMap, oldMap) fun get(name, dVal, (ts, ss)) = if tagIs structVar dVal then (ts, (name, (tagProject structVar dVal, path ^ name ^ ".", newMap)) :: ss) else if tagIs typeConstrVar dVal then ((name, (tagProject typeConstrVar dVal, path, newMap)) :: ts, ss) else (ts, ss) in univFold (tab, get, start) end (* Get all the structures and type constructors in a list of structures. *) fun allStructsAndTypes structs = List.foldl structsAndTypes ([], []) structs (* Turn a list of names and structures/types into a list of lists. Each entry in the result list is all those structures/types with the same name. *) fun getMatchedEntries entries = let (* Sort the items so that items with the same name are brought together. A signature is not allowed to have items of the same kind with the same name so this means that we are bringing together items from different structures. Then filter the result to produce sets of items with the same name. Discard singletons in the result. *) val sortedEntries = quickSort (fn (s1, _) => fn (s2, _) => s1 <= s2) entries (* *) fun getEquals([], _, [], res) = res (* End of empty list. *) | getEquals([], _, [_], res) = res (* Last item was singleton: discard *) | getEquals([], _, acc, res) = acc :: res (* Return last item. *) | getEquals((s, t) :: r, a: string, acc, res) = if a = s then getEquals(r, a, t :: acc, res) (* Same name as last item. *) else case acc of (* Different from last item: *) [] => getEquals(r, s, [t], res) (* No previous item. *) | [_] => getEquals(r, s, [t], res) (* Last was singleton: discard. *) | acc => getEquals(r, s, [t], acc :: res) in getEquals(sortedEntries, "", [], []) end (* Recursively apply the sharing constraints to corresponding types in a list of structures. *) fun structureSharing(structs, line, near) = let fun shareStructs structs = let val (allTypes, allSubstructs) = allStructsAndTypes structs (* Get the lists of structures and types to share. *) val matchedTypes = getMatchedEntries allTypes val matchedStructs = getMatchedEntries allSubstructs in List.app(fn types => (* Share types. *) case types of [] => raise List.Empty | (hd, hdName, hdMap) :: tl => (* Share the rest of the list with the first item. *) List.app(fn (t, tName, tMap) => shareTypes(hd, hdName, hdMap, t, tName, tMap, line, near)) tl) matchedTypes; List.app shareStructs matchedStructs (* Recursively share sub-structures. *) end in shareStructs(List.map(fn (s as Struct{name=sName, ...}) => (s, sName ^ ".", typeIdEnv())) structs) end in (* Process a sharing constraint. *) fun applySharingConstraint({shares, isType, line}, Env tEnv, near) : unit = let (* When looking up the structure and type names we look only in the signature in ML97. We add this to make it clear that we are only looking up in the signature otherwise we get confusing messages such as "type (int) has not been declared". *) fun lookupFailure locn msg = giveError (str, locn, lex) (msg ^ " in signature.") in if isType then let (* Type sharing. *) fun lookupSharing (name, locn) = lookupTyp ({ lookupType = #lookupType tEnv, lookupStruct = #lookupStruct tEnv }, name, lookupFailure locn) in case shares of nil => raise Empty | hd :: tl => let val first = lookupSharing hd in if isUndefinedTypeConstr(tsConstr first) then () else List.app (fn typ => shareTypes (lookupSharing typ, "", typeIdEnv(), first, "", typeIdEnv(), line, near)) tl end end else let (* structure sharing. *) fun getStruct(name, locn) = lookupStructureAsSignature (#lookupStruct tEnv, name, lookupFailure locn) in (* Now share all these signatures. *) structureSharing(List.mapPartial getStruct shares, line, near) end end (* applySharingConstraint *) end (* Sharing *) (* Look up a signature. Signatures can only be in the global environment. *) fun lookSig (name : string, lno : LEX.location) : signatures = case #lookupSig globalEnv name of SOME v => v | NONE => ( giveError (str, lno, lex)("Signature (" ^ name ^ ") has not been declared"); undefinedSignature ) (* Construct a signature. All the type IDs within the signature are variables. *) fun sigValue (str : sigs, Env env : env, _ : LEX.location, structPath) = case str of SignatureIdent(name, loc, declLoc) => signatureIdentValue(name, loc, declLoc, Env env, structPath) | WhereType {sigExp, typeVars, typeName, realisation, line, ...} => signatureWhereType(sigExp, typeVars, typeName, realisation, line, Env env, structPath) | SigDec(sigList, lno) => makeSigInto(sigList, Env env, lno, 0, structPath) and signatureIdentValue(name, loc, declLocs, _, structPath) = let (* Look up the signature and copy it to turn bound IDs into variables. This is needed because we may have sharing. *) val Signatures { name, tab, typeIdMap, firstBoundIndex, boundIds, locations, ...} = lookSig(name, loc); (* Remember the declaration location for possible browsing. *) val () = declLocs := locations val startNewIds = ! idCount (* Create a new variable ID for each bound ID. Type functions have to be copied to replace references to other bound IDs. These must be earlier in the list. *) fun makeNewIds([], _) = [] | makeNewIds( (oldId as TypeId{description, idKind=Bound { isDatatype, offset, arity, ...}, ...}) :: rest, typeMap ) = let val newId = makeVariableId(arity, isEquality oldId, isDatatype, false, description, structPath) fun newMap(id as TypeId{idKind=Bound{offset=n, ...}, ...}) = if n = offset then SOME newId else typeMap id | newMap _ = NONE in newId :: makeNewIds(rest, newMap) end | makeNewIds _ = raise InternalError "Map does not return Bound Id" val v = Vector.fromList(makeNewIds(boundIds, fn _ => NONE)) (* Map bound IDs only. *) val mapIds = if firstBoundIndex = startNewIds orelse null boundIds then typeIdMap (* Optimisation to reduce space: don't add map if it's not needed. *) else let fun mapId n = if n < firstBoundIndex then outerTypeIdEnv n else Vector.sub (v, n - firstBoundIndex) in composeMaps(typeIdMap, mapId) end in makeSignature(name, tab, !idCount, locations, mapIds, []) end and signatureWhereType(sigExp, typeVars, typeName, realisationType, line, Env globalEnv, structPath) = let (* We construct the signature into the result signature. When we apply the "where" we need to look up the types (and structures) only within the signature constrained by the "where" and not in the surrounding signature. e.g. If we have sig type t include S where type t = ... end we need to generate an error if S does not include t. Of course if it does that's also an error since t would be rebound! Equally, we must look up the right hand side of a where type in the surrounding scope, which will consist of the global environment and the signature excluding the entries we're adding here. *) val resSig as Signatures { typeIdMap = idMap, tab = resTab, ... } = sigValue(sigExp, Env globalEnv, lno, structPath) val sigEnv = makeEnv resTab fun lookupFailure msg = giveError (str, line, lex) (msg ^ " in signature.") (* Look up the type constructor in the signature. *) val sigTypeConstr = lookupTyp ({ lookupType = #lookupType sigEnv, lookupStruct = #lookupStruct sigEnv }, typeName, lookupFailure); (* The type, though, is looked up in the surrounding environment. *) fun lookupGlobal(s, locn) = lookupTyp ({ lookupType = #lookupType globalEnv, lookupStruct = #lookupStruct globalEnv }, s, giveError (str, locn, lex)) (* Process the type, looking up any type constructors. *) val realisation = assignTypes (realisationType, lookupGlobal, lex); fun cantSet(reason1, reason2) = let val typeEnv = { lookupType = fn s => case #lookupType globalEnv s of NONE => NONE | SOME t => SOME(t, NONE), lookupStruct = fn s => case #lookupStruct globalEnv s of NONE => NONE | SOME t => SOME(t, NONE) } in errorMsgNear (lex, true, fn n => displaySigs(sigExp, n), lno, PrettyBlock(3, false, [], [ PrettyString "Cannot apply type realisation.", PrettyBreak(1, 2), PrettyString("``" ^ typeName ^ "''"), PrettyBreak(1, 0), PrettyString reason1, PrettyBreak(1, 0), display(realisation, 1000, typeEnv), PrettyBreak(0, 0), PrettyString reason2 ])) end in (* Now try to set the target type to the type function. *) if isUndefinedTypeConstr (tsConstr sigTypeConstr) then () (* Probably because looking up the type constructor name failed. *) else let (* Map the type identifier to be set. *) val typeId = case tcIdentifier (tsConstr sigTypeConstr) of TypeId{idKind=Bound{offset, ...}, ...} => idMap offset | id => id in if not (isVariableId typeId) then (* May have been declared as type t=int or bound by a where type already. *) errorMsgNear (lex, true, fn n => displaySigs(sigExp, n), lno, PrettyBlock(3, false, [], [ PrettyString "Cannot apply type realisation.", PrettyBreak(1, 2), PrettyString("``" ^ typeName ^ "''"), PrettyBreak(1, 0), PrettyString " has already been set to", PrettyBreak(1, 0), printId typeId ])) else case typeId of TypeId{idKind=Bound { offset, ... }, ...} => ( case realId(offset-initTypeId) of VariableSlot {boundId=varId as TypeId{idKind=Bound{eqType, offset, isDatatype, ...}, ...}, ... } => ( (* The rule for "where type" says that we must check that an eqtype is only set to a type that permits equality and that the result is "well-formed". This seems to mean that if the type we're setting is a datatype (has constructors) it can only be set to a type that is a type name and not a general type function. *) if pling eqType andalso not(typePermitsEquality realisation) then cantSet ("is an eqtype but", "does not permit equality.") else case typeNameRebinding (typeVars, realisation) of SOME typeId => (* Renaming an existing constructor e.g. type t = s. Propagate the id. "s" may be free or it may be within the signature and equivalent to a sharing constraint. e.g. sig type t structure S: sig type s end where type s = t end. *) let (* We need to check what it has been set to if it's already set. *) val linkedId = case typeId of id as TypeId{idKind=Bound{offset, ...}, ...} => if offset < initTypeId then FreeSlot id (* Outside the sig: treat it as Free. *) else realId(offset-initTypeId) | id => FreeSlot id (* Free *) in case linkedId of VariableSlot _ => linkFlexibleTypeIds(typeId, varId) | _ => StretchArray.update(mapArray, offset-initTypeId, linkedId) end | NONE => if isDatatype (* The type we're trying to set is a datatype but the type we're setting it to isn't. *) then cantSet ("is a datatype but", "is not a simple type.") else let val typeId = makeTypeFunction( { location = line, description = "", name = typeName }, (typeVars, realisation)) in StretchArray.update(mapArray, offset-initTypeId, FreeSlot typeId) end ) | _ => (* Already checked. *) raise InternalError "setWhereType" ) | _ => (* Already checked. *) raise InternalError "setWhereType" end; resSig end (* signatureWhereType *) (* Constructs a signature and inserts it into an environment at a given offset. Generally offset will be zero except if we are including a signature. All the type IDs corresponding to local types are variables. There may be free IDs (and bound IDs?) as a result of "where type" constraints. *) and makeSigInto(sigsList: specs list, Env globalEnv, (* The surrounding environment excluding this sig. *) lno: LEX.location, offset: int, structPath): signatures = let (* Make a new signature. *) val newTable = makeSignatureTable(); (* Copy everything into the new signature. *) local (* ML 97 does not allow multiple declarations in a signature. *) fun checkAndEnter (enter, lookup, kind, locs) (s: string, v) = case lookup s of SOME _ => (* Already there. *) let fun getDecLoc(DeclaredAt loc :: _) = loc | getDecLoc [] = lno | getDecLoc(_::rest) = getDecLoc rest (* TODO: This shows the location of the identifier that is the duplicate. It would be nice if it could also show the original location. *) in errorNear (lex, true, fn n => displaySigs(str, n), getDecLoc(locs v), kind ^ " (" ^ s ^ ") is already present in this signature.") end | NONE => enter(s, v) val structEnv = makeEnv newTable; in val structEnv = { lookupVal = #lookupVal structEnv, lookupType = #lookupType structEnv, lookupFix = #lookupFix structEnv, lookupStruct = #lookupStruct structEnv, lookupSig = #lookupSig structEnv, lookupFunct = #lookupFunct structEnv, enterVal = checkAndEnter (#enterVal structEnv, #lookupVal structEnv, "Value", fn (Value{ locations, ...}) => locations), enterType = checkAndEnter (#enterType structEnv, #lookupType structEnv, "Type", tcLocations o tsConstr), enterStruct = checkAndEnter (#enterStruct structEnv, #lookupStruct structEnv, "Structure", fn Struct{locations, ...} => locations), (* These next three can't occur. *) enterFix = fn _ => raise InternalError "Entering fixity in signature", enterSig = fn _ => raise InternalError "Entering signature in signature", enterFunct = fn _ => raise InternalError "Entering functor in signature", allValNames = #allValNames structEnv } end (* Process the entries in the signature and allocate an address to each. *) fun processSig (signat: specs, offset : int, lno : LEX.location) : int = case signat of StructureSig (structList : structSigBind list, _) => let (* Each element in the list should be a structure binding. *) fun pStruct [] offset = offset | pStruct (({name, sigStruct = (sigStruct, _, _), line, ...}: structSigBind) :: t) offset = let (* Create a new surrounding environment to include the surrounding structure. This is the scope for any structures or types. Specifically, if we look up a type defined by a "where type" we use this environment and not the signature we're creating. *) val newEnv = { lookupVal = #lookupVal structEnv, lookupType = lookupDefault (#lookupType structEnv) (#lookupType globalEnv), lookupFix = #lookupFix structEnv, lookupStruct = lookupDefault (#lookupStruct structEnv) (#lookupStruct globalEnv), lookupSig = #lookupSig structEnv, lookupFunct = #lookupFunct structEnv, enterVal = #enterVal structEnv, enterType = #enterType structEnv, enterStruct = #enterStruct structEnv, enterFix = #enterFix structEnv, enterSig = #enterSig structEnv, enterFunct = #enterFunct structEnv, allValNames = fn () => (#allValNames structEnv () @ #allValNames globalEnv ()) }; val resSig = sigValue (sigStruct, Env newEnv, line, structPath ^ name ^ "."); (* Process the rest of the list before declaring the structure. *) val result = pStruct t (offset + 1); (* Make a structure. *) val locations = [DeclaredAt lno, SequenceNo (newBindingId lex)] val resStruct = makeFormalStruct (name, resSig, offset, locations) val () = #enterStruct structEnv (name, resStruct); in result (* One slot for each structure. *) end in pStruct structList offset end | ValSig {name=(name, nameLoc), typeof, line, ...} => let val errorFn = giveSpecError (signat, line, lex); fun lookup(s, locn) = lookupTyp ({ lookupType = lookupDefault (#lookupType structEnv) (#lookupType globalEnv), lookupStruct = lookupDefault (#lookupStruct structEnv) (#lookupStruct globalEnv) }, s, giveSpecError (signat, locn, lex)); (* Check for rebinding of built-ins. "it" is allowed here. *) val () = if name = "true" orelse name = "false" orelse name = "nil" orelse name = "::" orelse name = "ref" then errorFn("Specifying \"" ^ name ^ "\" is illegal.") else (); val typeof = assignTypes (typeof, lookup, lex) val locations = [DeclaredAt nameLoc, SequenceNo (newBindingId lex)] in (* If the type is not found give an error. *) (* The type is copied before being entered in the environment. This isn't logically necessary but has the effect of removing ref we put in for type constructions. *) #enterVal structEnv (name, mkFormal (name, ValBound, copyType (typeof, fn x => x, fn x => x), offset, locations)); (offset + 1) end | ExSig {name=(name, nameLoc), typeof, line, ...} => let val errorFn = giveSpecError (signat, line, lex); fun lookup(s, _) = lookupTyp ({ lookupType = lookupDefault (#lookupType structEnv) (#lookupType globalEnv), lookupStruct = lookupDefault (#lookupStruct structEnv) (#lookupStruct globalEnv) }, s, errorFn); val exType = case typeof of NONE => exnType | SOME typeof => mkFunctionType (assignTypes (typeof, lookup, lex), exnType) val locations = [DeclaredAt nameLoc, SequenceNo (newBindingId lex)] in (* If the type is not found give an error. *) (* Check for rebinding of built-ins. "it" is not allowed. *) if name = "true" orelse name = "false" orelse name = "nil" orelse name = "::" orelse name = "ref" orelse name = "it" then errorFn("Specifying \"" ^ name ^ "\" is illegal.") else (); #enterVal structEnv (name, mkFormal (name, Exception, exType, offset, locations)); (offset + 1) end | IncludeSig (structList : sigs list, _) => let (* include sigid ... sigid or include sigexp. For simplicity we handle the slightly more general case of a list of signature expressions. The contents of the signature are added to the environment. *) fun includeSigExp (str: sigs, offset) = let val address = ref offset (* The environment for the signature being included must at least include local types. *) val includeEnv = { lookupVal = #lookupVal structEnv, lookupType = lookupDefault (#lookupType structEnv) (#lookupType globalEnv), lookupFix = #lookupFix structEnv, lookupStruct = lookupDefault (#lookupStruct structEnv) (#lookupStruct globalEnv), lookupSig = #lookupSig structEnv, lookupFunct = #lookupFunct structEnv, enterVal = #enterVal structEnv, enterType = #enterType structEnv, enterStruct = #enterStruct structEnv, enterFix = #enterFix structEnv, enterSig = #enterSig structEnv, enterFunct = #enterFunct structEnv, allValNames = #allValNames structEnv } val resultSig = sigValue(str, Env includeEnv, lno, structPath) (* Renumber the run-time offsets for Values and Structures as we enter them into the surrounding signature. *) fun newAccess(Formal _) = let val addr = !address in address := addr+1; Formal addr end | newAccess _ = raise InternalError "newAccess: Not Formal" fun enterType(name, tySet as TypeConstrSet(ty, tcConstructors)) = let (* Process value constructors with the type. Because values can't be redefined within a signature we can't have overridden this with a new declaration. We don't allocate run-time IDs to type identifiers. That's done at the end when we've sorted out any sharing *) fun copyConstructor(Value { name, typeOf, access, class, locations, ... }) = Value{name=name, typeOf = typeOf, access=newAccess access, class=class, locations=locations, references=NONE, instanceTypes=NONE} val newType = case tcConstructors of [] => tySet (* Not a datatype. *) | constrs => let val newTy = makeTypeConstructor(tcName ty, tcTypeVars ty, tcIdentifier ty, tcLocations ty) in TypeConstrSet(newTy, List.map copyConstructor constrs) end; in #enterType structEnv(name, newType) end and enterStruct(name, Struct{name=strName, signat, access, locations, ...}) = #enterStruct structEnv (name, Struct{ name = strName, signat = signat, access = newAccess access, locations = locations}) and enterVal(dName, Value { name, typeOf, access, class, locations, ... }) = #enterVal structEnv (dName, Value{name=name, typeOf = typeOf, access=newAccess access, class=class, locations=locations, references=NONE, instanceTypes=NONE}) val tsvEnv = { enterType = enterType, enterStruct = enterStruct, enterVal = enterVal } val () = openSignature(resultSig, tsvEnv, "") in ! address end in List.foldl includeSigExp offset structList end | Sharing (share : shareConstraint) => (* Sharing constraint. *) let (* In ML90 it was possible to share with any identifier in scope. In ML97 sharing is restricted to identifiers in the "spec". *) val envForSharing = Env structEnv in applySharingConstraint (share, envForSharing, str); offset (* No entry *) end | CoreType {dec, ...} => let (* datatype or type binding(s) *) (* This pass puts the data constructors into the environment. *) val addrs = ref offset (* Pass2 creates value constructors of datatypes as global values. Rather than complicate pass2 by trying to make formal values in this case it's easier to trap the value constructors at this point. N.B. We may get constructors from a datatype declaration or from datatype replication. *) fun convertValueConstr(Value{class=class, typeOf, locations, name, ...}) = Value{class=class, typeOf=typeOf, access=Formal(!addrs before (addrs := !addrs+1)), name=name, locations=locations, references=NONE, instanceTypes=NONE} fun enterVal(name, v) = (#enterVal structEnv)(name, convertValueConstr v) (* Record all the types and enter them later. *) val datatypeList = searchList () val enterType = #enter datatypeList val newEnv = { lookupVal = #lookupVal structEnv, lookupType = lookupDefault (#lookup datatypeList) (lookupDefault (#lookupType structEnv) (#lookupType globalEnv)), lookupFix = #lookupFix structEnv, lookupStruct = lookupDefault (#lookupStruct structEnv) (#lookupStruct globalEnv), lookupSig = #lookupSig structEnv, lookupFunct = #lookupFunct structEnv, enterVal = enterVal, enterType = enterType, enterStruct = #enterStruct structEnv, enterFix = #enterFix structEnv, enterSig = #enterSig structEnv, enterFunct = #enterFunct structEnv, allValNames = #allValNames structEnv }; fun makeId (eq, isdt, (args, EmptyType), loc) = makeVariableId(length args, eq, isdt, true, loc, structPath) | makeId (_, _, (typeVars, decType), { location, name, description }) = makeTypeFunction( { location = location, name = structPath ^ name, description = description }, (typeVars, decType)) (* We need a map to look up types. This is only used in one place: if the item we're processing is a datatype then we need to look at the bindings of type identifiers to compute equality correctly. e.g. type t = int*int datatype s = X of t . *) fun equalityForId(TypeId{idKind=TypeFn(_, equiv), ...}) = typePermitsEquality equiv | equalityForId id = isEquality id fun findEquality n = if n < initTypeId then equalityForId(outerTypeIdEnv n) else case realId(n-initTypeId) of FreeSlot t => equalityForId t | VariableSlot { boundId, ...} => equalityForId boundId | _ => raise InternalError "internalMap: Not bound or Free" val _ : types = pass2 (dec, makeId, Env newEnv, lex, findEquality); (* Replace the constructor list for the datatype with a new set. We need to have separate addresses for the constructors in the datatype environment from those in the value environment. This is needed for compatibility with the "signature" constructed from a struct...end block. *) fun enterFinalType (name, TypeConstrSet(tyCons, constrs)) = #enterType structEnv (name, TypeConstrSet(tyCons, List.map convertValueConstr constrs)) val _ = #apply datatypeList enterFinalType in ! addrs end (* end processSig *); val _ = List.foldl (fn (signat, offset) => processSig (signat, offset, lno)) offset sigsList val locations = [DeclaredAt lno, SequenceNo (newBindingId lex)] in makeSignature("", newTable, ! idCount, locations, typeIdEnv (), []) end (* Process the contents of the signature. *) val resultSig = sigValue (str, Env globalEnv, lno, "") (* After the signature has been built and any sharing or "where type" constraints have been applied we replace the remaining variable stamps by bound stamps. *) val nextAddress = getNextRuntimeOffset resultSig val typeCounter = ref initTypeId; val addrCounter = ref nextAddress (* Construct final bound IDs for each distinct type ID in the array. *) local fun mapIds n = if n = !idCount-initTypeId then ([], []) else ( (* Process lowest numbered IDs first since they represent the result of any sharing. *) case realId n of VariableSlot { boundId = TypeId{ idKind=Bound{eqType, isDatatype, arity, ... }, description = { name, location, description}, ...}, descriptions, ...} => let (* Need to make a new ID. *) (* If we have sharing we want to produce a description that expresses that. *) val descript = case descriptions of descs as _ :: _ :: _ => "sharing " ^ String.concatWith "," descs | _ => description (* Original description. *) val newId = let (* For each ID we need a new entry in the ID vector. We also need an entry in the run-time vector for the structure so that we can pass the equality/print value at run-time. *) val n = !typeCounter val () = typeCounter := n + 1 val addr = ! addrCounter val () = addrCounter := addr + 1 val description = { name = name, location = location, description = descript } in makeBoundId(arity, Formal addr, n, pling eqType, isDatatype, description) end (* Update the entry for any sharing. *) val () = StretchArray.update(mapArray, n, FreeSlot newId) val (distinctIds, mappedIds) = mapIds (n+1) in (newId :: distinctIds, newId :: mappedIds) end | FreeSlot (TypeId{idKind=TypeFn(args, equiv), description, ...}) => let (* Generally, IDs in a FreeSlot will be either Bound or Free but they could be TypeFunctions as a result of a "where type" and the function could involve type IDs within the signature. We have to copy the ID now after all the new IDs have been created. *) fun copyId(TypeId{idKind=Bound { offset, ...}, ...}) = if offset < initTypeId then NONE else (* At this stage we've overwritten all entries with FreeSlots. *) ( case realId(offset-initTypeId) of FreeSlot id => SOME id | _ => raise InternalError "mapIds:copyTypeConstr" ) | copyId _ = NONE val copiedEquiv = copyType(equiv, fn x => x, fn tcon => copyTypeConstr (tcon, copyId, fn x => x, fn s => s)) (* For the moment always use a Free ID here. *) val copiedId = makeTypeFunction(description, (args, copiedEquiv)) (* Update the array with this copied version. If other subsequent type functions use this entry they will then pick up the copied version. Because "where type" constraints can only refer to earlier types we have to process this from earlier to later. *) val () = StretchArray.update(mapArray, n, FreeSlot copiedId) val (distinctIds, mappedIds) = mapIds (n+1) in (distinctIds, copiedId :: mappedIds) end | FreeSlot id => (* Free or shares with existing type ID. *) let val (distinctIds, mappedIds) = mapIds (n+1) in (distinctIds, id :: mappedIds) end | _ => raise InternalError "mapIds" ) val (distinctIds, mappedIds) = mapIds 0 val mapVector = Vector.fromList mappedIds val resVector = Vector.fromList distinctIds in fun mapFunction n = if n < initTypeId then outerTypeIdEnv n else Vector.sub(mapVector, n-initTypeId) val distinctIds = distinctIds val allMapped = Vector.length mapVector = Vector.length resVector end in let val Signatures { tab, name, locations, typeIdMap, ... } = resultSig (* We have allocated Bound Ids starting at initTypeId. If there has not been any sharing or where type constraints these Ids will correspond exactly to the bound Ids of the signature and we can use the result without any further mapping. This is particularly the case if we have simply used a named signature here. If there have been some sharing or where type we have to produce a new map so that the boundId list consists of contiguously numbered items. This is an optimisation to reduce the space of the final signature. *) val finalMap = if allMapped then typeIdMap else composeMaps(typeIdMap, mapFunction) in makeSignature(name, tab, initTypeId, locations, finalMap, distinctIds) end end (* sigVal *); structure Sharing = struct type sigs = sigs type structSigBind = structSigBind type parsetree = parsetree type typeParsetree = typeParsetree type typeVarForm = typeVarForm type pretty = pretty type ptProperties = ptProperties type env = env type signatures = signatures type lexan = lexan type typeId = typeId type specs = specs end end; diff --git a/mlsource/MLCompiler/STRUCTURES_.ML b/mlsource/MLCompiler/STRUCTURES_.ML index 8a9704d3..fa274933 100644 --- a/mlsource/MLCompiler/STRUCTURES_.ML +++ b/mlsource/MLCompiler/STRUCTURES_.ML @@ -1,3310 +1,3310 @@ (* Copyright (c) 2000 Cambridge University Technical Services Limited - Modified D.C.J. Matthews 2001-2016 + Modified D.C.J. Matthews 2001-2016, 2020 This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) (* Title: Module Structure and Operations. Author: Dave Matthews, Cambridge University Computer Laboratory Copyright Cambridge University 1985 *) functor STRUCTURES_ ( structure LEX : LEXSIG structure CODETREE : CODETREESIG structure STRUCTVALS : STRUCTVALSIG; structure VALUEOPS : VALUEOPSSIG; structure EXPORTTREE: EXPORTTREESIG structure TYPETREE : TYPETREESIG structure PARSETREE : PARSETREESIG structure PRETTY : PRETTYSIG structure COPIER: COPIERSIG structure TYPEIDCODE: TYPEIDCODESIG structure SIGNATURES: SIGNATURESSIG structure DEBUGGER : DEBUGGER structure UTILITIES : sig val noDuplicates: (string * 'a * 'a -> unit) -> { apply: (string * 'a -> unit) -> unit, enter: string * 'a -> unit, lookup: string -> 'a option }; val searchList: unit -> { apply: (string * 'a -> unit) -> unit, enter: string * 'a -> unit, lookup: string -> 'a option }; val splitString: string -> { first:string,second:string } end; structure UNIVERSALTABLE: sig type universal = Universal.universal type univTable type 'a tag = 'a Universal.tag val univEnter: univTable * 'a tag * string * 'a -> unit; val univLookup: univTable * 'a tag * string -> 'a option; val univFold: univTable * (string * universal * 'a -> 'a) * 'a -> 'a; end; -structure DEBUG: DEBUGSIG +structure DEBUG: DEBUG sharing LEX.Sharing = VALUEOPS.Sharing = TYPETREE.Sharing = PARSETREE.Sharing = PRETTY.Sharing = EXPORTTREE.Sharing = STRUCTVALS.Sharing = COPIER.Sharing = CODETREE = UNIVERSALTABLE = TYPEIDCODE.Sharing = SIGNATURES.Sharing = DEBUGGER.Sharing ) : STRUCTURESSIG = (*****************************************************************************) (* STRUCTURES functor body *) (*****************************************************************************) struct open Misc; open PRETTY; open COPIER; open LEX; open CODETREE; open STRUCTVALS; open VALUEOPS; open TYPETREE; open PARSETREE; open UTILITIES; open DEBUG; open UNIVERSALTABLE; open Universal; (* for tag record selectors *) open EXPORTTREE; open TYPEIDCODE open SIGNATURES open DEBUGGER (* Transitional bindings. Calls to these should be replaced by pattern matching. *) fun sigTab (Signatures {tab,...}) = tab and sigMinTypes (Signatures {firstBoundIndex,...}) = firstBoundIndex and sigMaxTypes (Signatures {firstBoundIndex, boundIds,...}) = firstBoundIndex + List.length boundIds and sigTypeIdMap (Signatures {typeIdMap, ...}) = typeIdMap and sigBoundIds (Signatures {boundIds, ...}) = boundIds fun structName (Struct {name,...}) = name and structAccess (Struct {access,...}) = access and structLocations (Struct {locations,...}) = locations and structSignat (Struct {signat,...}) = signat (* Union of the various kinds of core language declaration. Structures are included because they can be declared by opening a structure with substructures. *) datatype coreDeclaration = CoreValue of values | CoreType of typeConstrSet | CoreFix of string*fixStatus (* Include the name because it isn't part of fixStatus. *) | CoreStruct of structVals (* Description of the actions to perform when a structure matches a signature. *) datatype valueMatching = ValueMatch of { sourceValue: values, targetType: types, coercion: valueCoercions } | StructureMatch of { sourceStructure: structVals, contentsMatch: structureMatch} | TypeIdMatch of { sourceIdNo: int, isEquality: bool } and valueCoercions = (* The coercions that may apply to a value. *) NoCoercion | ExceptionToValue | ConstructorToValue withtype structureMatch = (int * valueMatching) list (* "structs" is the abstract syntax for the module language. *) datatype structValue = StructureIdent of (* A structure name *) { name: string, (* The name *) valRef: structVals option ref, (* The variable found. *) location: location } | StructDec of (* struct ... end *) { alist: structDec list, (* List of items in it. *) location: location, matchToResult: structureMatch ref } | FunctorAppl of (* Application of a functor. *) { name: string, arg: structValue, valRef: functors option ref, (* The functor looked up. *) nameLoc: location, (* The location of the name itself. *) fullLoc: location, (* The location of the full application. *) argIds: { source: typeId, dest: typeId } list ref, (* The IDs that are required in the arguments. *) resIds: { source: typeId, dest: typeId } list ref, (* Generative IDs in the result. *) matchToArgument: structureMatch ref } | LetDec of (* let strdec in strexp. *) { decs: structDec list, body: structValue, line: location } | SigConstraint of (* Constraint of str to match sig. *) { str: structValue, (* Structure to constrain *) csig: sigs, (* Constraining signature *) opaque: bool, (* True if opaque, false if transparent. *) sigLoc: location, opaqueIds: { source : typeId, dest: typeId } list ref, matchToConstraint: structureMatch ref } and structDec = StructureDec of (* List of structure decs *) { bindings: structBind list, typeIdsForDebug: typeId list ref, line: location } | CoreLang of (* Any other decln. *) { dec: parsetree, (* The value *) vars: coreDeclaration list ref, (* The declarations *) location: location } | Localdec of (* Local strdec in strdec. *) { decs: structDec list, body: structDec list, line: location } withtype structBind = { name: string, (* The name of the structure *) nameLoc: location, haveSig: bool, (* Whether we moved an explicit signature to the value. *) value: structValue, (* And its value *) valRef: structVals option ref, (* The structure variable declared. *) line: location } fun mkStructIdent (name, location) = StructureIdent { name = name, valRef = ref NONE, location = location } (* For struct...end, make a signature to accept the values. *) fun mkStruct(alist, location) = StructDec { alist = alist, location = location, matchToResult = ref [] }; fun mkCoreLang (dec, location) = CoreLang { dec = dec, vars = ref [], location = location }; fun mkFunctorAppl (name, arg, nameLoc, fullLoc) = FunctorAppl { name = name, arg = arg, valRef = ref NONE, nameLoc = nameLoc, fullLoc = fullLoc, argIds = ref nil, resIds = ref nil, matchToArgument = ref [] }; fun mkFormalArg (name, signat) = { name = name, sigStruct = signat, valRef = ref NONE } fun mkLocaldec (decs, body, line) = Localdec { decs = decs, body = body, line = line }; fun mkLetdec (decs, body, line) = LetDec { decs = decs, body = body, line = line }; fun mkSigConstraint(str, csig, opaque, sigLoc) = SigConstraint { str=str, csig=csig, opaque=opaque, sigLoc=sigLoc, opaqueIds=ref nil, matchToConstraint = ref [] } fun mkStructureDec(bindings, line) = StructureDec { bindings = bindings, typeIdsForDebug = ref [], line = line } fun mkStructureBinding ((name, nameLoc), signat, value, fullLoc): structBind = let (* If there's an explicit signature move that to a constraint. *) val value = case signat of NONE => value | SOME (csig, opaque, sigLoc) => mkSigConstraint(value, csig, opaque, sigLoc) in { name = name, nameLoc = nameLoc, haveSig = isSome signat, value = value, valRef = ref NONE, line = fullLoc } end; type formalArgStruct = { name: string, sigStruct: sigs, valRef: structVals option ref } (* The structure variable. *) (* Top level declarations and program. *) datatype topdec = StrDec of structDec * typeId list ref (* Structure decs and core lang. *) | FunctorDec of functorBind list * location (* List of functor decs. *) | SignatureDec of sigBind list * location (* List of signature decs *) withtype (* Functor binding. *) functorBind = { name: string, nameLoc: location, haveSig: bool, (* Whether we moved an explicit signature to the value. *) body: structValue, arg: formalArgStruct, valRef: functors option ref, (* The functor variable declared. *) resIds: { source: typeId, dest: typeId } list ref, line: location, matchToResult: structureMatch ref, (* If we are debugging we need these at code-gen time. *) debugArgVals: values list ref, debugArgStructs: structVals list ref, debugArgTypeConstrs: typeConstrSet list ref } and sigBind = { name: string, (* The name of the signature *) nameLoc: location, sigStruct: sigs,(* Its value *) sigRef: signatures ref, (* The "value" of the signature. *) line: location } fun mkTopDec t = StrDec(t, ref nil) and mkFunctorDec s = FunctorDec s and mkSignatureDec s = SignatureDec s; fun mkFunctorBinding (name, nameLoc, signat, body, arg, line): functorBind = let (* If there's an explicit signature move that to a constraint. *) val body = case signat of NONE => body | SOME (csig, opaque, sigLoc) => mkSigConstraint(body, csig, opaque, sigLoc) in { name = name, nameLoc = nameLoc, haveSig = isSome signat, body = body, arg = arg, valRef = ref NONE, resIds = ref nil, line = line, matchToResult = ref [], debugArgVals = ref [], debugArgStructs = ref [], debugArgTypeConstrs = ref [] } end and mkSignatureBinding ((name, nameLoc), sg, ln) = { name = name, nameLoc = nameLoc, sigStruct = sg, line = ln, sigRef = ref undefinedSignature } type program = topdec list * location fun mkProgram tl = tl (* Pretty printing *) fun displayList ([], _, _) _ = [] | displayList ([v], _, depth) dodisplay = if depth <= 0 then [PrettyString "..."] else [dodisplay (v, depth)] | displayList (v::vs, separator, depth) dodisplay = if depth <= 0 then [PrettyString "..."] else let val brk = if separator = "," orelse separator = ";" then 0 else 1 in PrettyBlock (0, false, [], [ dodisplay (v, depth), PrettyBreak (brk, 0), PrettyString separator ] ) :: PrettyBreak (1, 0) :: displayList (vs, separator, depth - 1) dodisplay end (* displayList *) fun displayStruct (str, depth: FixedInt.int) = if depth <= 0 (* elide further text. *) then PrettyString "..." else case str of StructureDec { bindings = structList, ...} => let fun displayStructBind ( {name, haveSig, value, ...}: structBind, depth) = let (* If we desugared this before, return it to its original form. *) val (sigStruct, value) = case (haveSig, value) of (true, SigConstraint{str, csig, opaque, sigLoc, ...}) => (SOME(csig, opaque, sigLoc), str) | _ => (NONE, value) in PrettyBlock (3, false, [], PrettyString name :: ( case sigStruct of (* Signature is optional *) NONE => [] | SOME (sigStruct, opaque, _) => [ PrettyString (if opaque then " :>" else " :"), PrettyBreak (1, 0), displaySigs (sigStruct, depth - 1) ] ) @ [ PrettyString " =", PrettyBreak (1, 0), displayStructValue (value, depth - 1) ] ) end in PrettyBlock (3, false, [], PrettyString "structure" :: PrettyBreak (1, 0) :: displayList (structList, "and", depth) displayStructBind ) end | Localdec {decs, body, ...} => PrettyBlock (3, false, [], PrettyString "local" :: PrettyBreak (1, 0) :: displayList (decs, ";", depth - 1) displayStruct @ [ PrettyBreak (1, 0), PrettyString "in", PrettyBreak (1, 0)] @ displayList (body, ";", depth - 1) displayStruct @ [ PrettyBreak (1, 0), PrettyString "end" ] ) | CoreLang {dec, ...} => displayParsetree (dec, depth - 1) and displayStructValue (str, depth) = if depth <= 0 (* elide further text. *) then PrettyString "..." else case str of StructureIdent {name, ...} => PrettyString name | StructDec {alist, ...} => PrettyBlock (1, true, [], PrettyString "struct" :: PrettyBreak (1, 0) :: displayList (alist, "", depth) displayStruct @ [ PrettyBreak (1, 0), PrettyString "end"] ) | FunctorAppl {name, arg, ...} => PrettyBlock (1, false, [], [ PrettyString (name ^ "("), PrettyBreak (0, 0), displayStructValue (arg, depth), PrettyBreak (0, 0), PrettyString ")" ] ) | LetDec {decs, body, ...} => PrettyBlock (3, false, [], PrettyString "let" :: PrettyBreak (1, 0) :: displayList (decs, ";", depth - 1) displayStruct @ [ PrettyBreak (1, 0), PrettyString "in", PrettyBreak (1, 0), displayStructValue (body, depth - 1) ] @ [ PrettyBreak (1, 0), PrettyString "end" ] ) | SigConstraint{str, csig, opaque, ...} => PrettyBlock (0, false, [], [ displayStructValue (str, depth - 1), PrettyString (if opaque then " :>" else " :"), PrettyBreak (1, 0), displaySigs (csig, depth - 1) ] ) fun displayTopDec(top, depth) = if depth <= 0 (* elide further text. *) then PrettyString "..." else case top of StrDec(s, _) => displayStruct(s, depth) | SignatureDec (structList : sigBind list, _) => let fun displaySigBind ({name, sigStruct, ...}: sigBind, depth) = PrettyBlock (3, false, [], [ PrettyString (name ^ " ="), PrettyBreak (1, 0), displaySigs (sigStruct, depth - 1) ] ) in PrettyBlock (3, false, [], PrettyString "signature" :: PrettyBreak (1, 0) :: displayList (structList, "and", depth) displaySigBind ) end | FunctorDec (structList : functorBind list, _) => let fun displayFunctBind ( {name, arg={name=argName, sigStruct=argStruct, ...}, haveSig, body, ...}, depth) = let val (sigStruct, body) = case (haveSig, body) of (true, SigConstraint{str, csig, opaque, sigLoc, ...}) => (SOME(csig, opaque, sigLoc), str) | _ => (NONE, body) in PrettyBlock (3, false, [], PrettyString (name ^ "(") :: PrettyBreak (1, 0) :: PrettyBlock (1, false, [], ( if argName = "" then [] else [ PrettyString (argName ^ " :"), PrettyBreak (1, 2)] ) @ [displaySigs (argStruct, depth - 1)] ) :: PrettyString ")" :: ( case sigStruct of NONE => [] (* Signature is optional *) | SOME (sigStruct, opaque, _) => [ PrettyString(if opaque then " :>" else " :"), PrettyBreak (1, 0), displaySigs (sigStruct, depth - 1) ] ) @ [ PrettyBreak (1, 0), PrettyString "=", PrettyBreak (1, 0), displayStructValue (body, depth - 1) ] ) end in PrettyBlock (3, false, [], PrettyString "functor" :: PrettyBreak (1, 0) :: displayList (structList, "and", depth) displayFunctBind ) end (* End displayTopDec *) fun displayProgram ((sl, _), d) = PrettyBlock(0, true, [], displayList (sl, "", d) displayTopDec ) fun structExportTree(navigation, s: structDec) = let (* Common properties for navigation and printing. *) val commonProps = PTprint(fn d => displayStruct(s, d)) :: exportNavigationProps navigation fun asParent () = structExportTree(navigation, s) in case s of StructureDec{ bindings = sbl, line = location, ...} => let fun exportSB(navigation, sb as {name, nameLoc, haveSig, value, line, valRef=ref structOpt, ...}) = let (* If we desugared this before, return it to its original form. *) val (sigStruct, value) = case (haveSig, value) of (true, SigConstraint{str, csig, opaque, sigLoc, ...}) => (SOME(csig, opaque, sigLoc), str) | _ => (NONE, value) fun exportThis () = exportSB(navigation, sb) (* Three groups: name, signature and structures. It's all complicated because the signature may not be present. *) val locProps = case structOpt of SOME(Struct{locations, ...}) => definingLocationProps locations | _ => [] fun getName () = let val next = case sigStruct of SOME _ => getSigStruct | NONE => getValue in getStringAsTree({parent=SOME exportThis, previous=NONE, next=SOME next}, name, nameLoc, locProps) end and getSigStruct () = let val next = SOME getValue val (theSig, _, _) = valOf sigStruct in sigExportTree({parent=SOME exportThis, previous=SOME getName, next=next}, theSig) end and getValue () = let val previous = case sigStruct of NONE => getName | SOME _ => getSigStruct in structValueExportTree({parent=SOME exportThis, previous=SOME previous, next=NONE}, value) end in (line, PTfirstChild getName :: exportNavigationProps navigation) end val expChild = exportList(exportSB, SOME asParent) sbl in (location, expChild @ commonProps) end | CoreLang {dec, ...} => (* A value parse-tree entry. *) getExportTree(navigation, dec) | Localdec {decs, body, line, ...} => (line, exportList(structExportTree, SOME asParent) (decs @ body) @ commonProps) end and structValueExportTree(navigation, s: structValue) = let (* Common properties for navigation and printing. *) val commonProps = PTprint(fn d => displayStructValue(s, d)) :: exportNavigationProps navigation fun asParent () = structValueExportTree(navigation, s) in case s of StructureIdent { valRef = ref var, location, ... } => let val locs = case var of SOME(Struct{locations, ...}) => locations | NONE => [] in (* Get the location properties for the identifier. *) (location, mapLocationProps locs @ commonProps) end | StructDec{ location, alist, ...} => (location, exportList(structExportTree, SOME asParent) alist @ commonProps) | FunctorAppl { valRef, name, nameLoc, fullLoc, arg, ... } => let val locs = case ! valRef of SOME(Functor { locations, ...}) => locations | NONE => [] (* Navigate between the functor name and the argument. *) (* The first position is the expression, the second the type *) fun getFunctorName () = getStringAsTree({parent=SOME asParent, previous=NONE, next=SOME getFunctorArg}, name, nameLoc, mapLocationProps locs) and getFunctorArg () = structValueExportTree({parent=SOME asParent, previous=SOME getFunctorName, next=NONE}, arg) in (fullLoc, PTfirstChild getFunctorName :: commonProps) end | LetDec {decs, body, line, ...} => let (* For simplicity just merge these as a single list. *) datatype allEntries = Value of structValue | Dec of structDec fun exportEntries(navigation, Value strval) = structValueExportTree(navigation, strval) | exportEntries(navigation, Dec strdec) = structExportTree(navigation, strdec) in (line, exportList(exportEntries, SOME asParent) (List.map Dec decs @ [Value body]) @ commonProps) end | SigConstraint { str, csig, sigLoc, ... } => let (* Navigate between the functor name and the argument. *) (* The first position is the expression, the second the type *) fun getStructure () = structValueExportTree({parent=SOME asParent, previous=NONE, next=SOME getSignature}, str) and getSignature () = sigExportTree({parent=SOME asParent, previous=SOME getStructure, next=NONE}, csig) in (sigLoc, PTfirstChild getStructure :: commonProps) end end fun topDecExportTree(navigation, top: topdec) = let (* Common properties for navigation and printing. *) val commonProps = PTprint(fn d => displayTopDec(top, d)) :: exportNavigationProps navigation fun asParent () = topDecExportTree(navigation, top) in case top of StrDec(s, _) => structExportTree(navigation, s) | SignatureDec(sigs, location) => let fun exportSB(navigation, sb as {name, nameLoc, sigStruct, line, sigRef=ref(Signatures{locations, ...}), ...}) = let fun exportThis () = exportSB(navigation, sb) fun getName () = getStringAsTree({parent=SOME exportThis, previous=NONE, next=SOME getSig}, name, nameLoc, definingLocationProps locations) and getSig () = sigExportTree({parent=SOME exportThis, previous=SOME getName, next=NONE}, sigStruct) in (line, PTfirstChild getName :: exportNavigationProps navigation) end in (location, exportList(exportSB, SOME asParent) sigs @ commonProps) end | FunctorDec(fbl, location) => let fun exportFB(navigation, fb as {name, nameLoc, haveSig, arg={sigStruct=argStruct, ...}, body, line, valRef=ref optFunc, ...}) = let val locations = case optFunc of SOME(Functor{locations, ...}) => locations | _ => [] val (sigStruct, body) = case (haveSig, body) of (true, SigConstraint{str, csig, opaque, sigLoc, ...}) => (SOME(csig, opaque, sigLoc), str) | _ => (NONE, body) val fbProps = exportNavigationProps navigation fun exportThis () = exportFB(navigation, fb) (* Because the signature is optional navigation on the arg and body depends on whether there's a signature. *) fun getName() = getStringAsTree({parent=SOME exportThis, previous=NONE, next=SOME getArg}, name, nameLoc, definingLocationProps locations) and getArg() = let val next = if isSome sigStruct then getSig else getBody in sigExportTree({parent=SOME exportThis, previous=SOME getName, next=SOME next}, argStruct) end and getSig() = sigExportTree({parent=SOME exportThis, previous=SOME getArg, next=SOME getBody}, #1(valOf sigStruct)) and getBody() = let val previous = if isSome sigStruct then getSig else getArg in structValueExportTree({parent=SOME exportThis, previous=SOME previous, next=NONE}, body) end in (line, PTfirstChild getName :: fbProps) end val expChild = exportList(exportFB, SOME asParent) fbl in (location, expChild @ commonProps) end end (* Convert a "program" into a navigable tree. *) fun structsExportTree (parentTree, trees: program) = let val parentTreeNav = exportNavigationProps parentTree (* The top level is actually a list. *) fun exportTree(([], location)) = (location, parentTreeNav) | exportTree(topdec as (sl, location)) = let fun getEntry(this as (s :: sl), getPrevious) (): exportTree = topDecExportTree( { parent = SOME(fn () => exportTree topdec), (* Parent is this. *) previous = getPrevious, (* If we have a successor then that is the entry and its predecessor returns here. *) next = case sl of [] => NONE | t => SOME(getEntry(t, SOME(getEntry(this, getPrevious)))) }, s ) | getEntry _ () = raise Empty in (location, parentTreeNav @ [PTfirstChild(getEntry(sl, NONE))]) end in exportTree trees end (* Puts out an error message and then prints the piece of tree. *) fun errorMsgNear (lex, hard, near, lno, message) : unit = let val parameters = debugParams lex val errorDepth = getParameter errorDepthTag parameters in reportError lex { hard = hard, location = lno, message = message, context = SOME(near errorDepth) } end; (* TODO: If the item being errored is in a substructure it currently doesn't report the name of the substructure. *) (* Report an error about signature-structure matching. *) fun sigStructMatchMsg (lex, near, lno, structName) (doDisplay: 'a -> pretty) (structValue: 'a, sigValue: 'a, reason) = let val message = PrettyBlock(3, true, [], [ PrettyString ("Structure does not match signature" ^ (if structName = "" then "." else " in sub-structure " ^ structName)), PrettyBreak(1, 0), PrettyBlock(3, false, [], [ PrettyString "Signature:", PrettyBreak(1, 0), doDisplay sigValue ]), PrettyBreak(1, 0), PrettyBlock(3, false, [], [ PrettyString "Structure:", PrettyBreak(1, 0), doDisplay structValue ]), PrettyBreak(1, 0), PrettyBlock(3, false, [], [ PrettyString "Reason:", PrettyBreak(1, 0), reason ]) ]) in errorMsgNear(lex, true, near, lno, message) end fun sigStructMissingMsg (lex, near, lno, structName) (doDisplay: 'a -> pretty) (sigValue: 'a) = let val message = PrettyBlock(3, true, [], [ PrettyString ("Structure does not match signature" ^ (if structName = "" then "." else " in sub-structure " ^ structName)), PrettyBreak(1, 0), PrettyBlock(3, false, [], [ PrettyString "Signature:", PrettyBreak(1, 0), doDisplay sigValue ]), PrettyBreak(1, 0), PrettyBlock(3, false, [], [ PrettyString "Structure:", PrettyBreak(1, 0), PrettyString "Not present" ]) ]) in errorMsgNear(lex, true, near, lno, message) end (* Older version: prints just a string message. *) fun errorNear(lex, hard, near, lno, message: string) = errorMsgNear (lex, hard, near, lno, PrettyBlock (0, false, [], [PrettyString message])) fun errorDepth lex = let open DEBUG val parameters = LEX.debugParams lex in getParameter errorDepthTag parameters end (* Error message routine for lookupType and lookupStructure. *) fun giveError (sVal : structValue, lno : LEX.location, lex : lexan) : string -> unit = fn (message : string) => errorNear (lex, true, fn n => displayStructValue(sVal, n), lno, message); (* Turn a result from matchTypes into a pretty structure so that it can be included in a message. *) (* TODO: When reporting type messages from inside the structure we should use the environment from within the structure and for type within the signature the signature env. *) fun matchErrorReport(lex, structTypeEnv, sigTypeEnv) = unifyTypesErrorReport(lex, structTypeEnv, sigTypeEnv, "match") datatype matchTypeResult = MatchError of matchResult | MatchSuccess of types (* Check that two types match. Returns either an error result or the set of polymorphic variables for the source and the target. *) fun matchTypes (candidate, target, targMap: int -> typeId option, _) = let fun copyId(TypeId{idKind=Bound{ offset, ...}, ...}) = targMap offset | copyId _ = NONE fun copyATypeConstr tcon = copyTypeConstr(tcon, copyId, fn x => x, fn s => s) fun copyTarget t = (* Leave type variables. *) copyType (t, fn x => x, copyATypeConstr); val copiedTarget = copyTarget target (* Do the match to a version of the candidate with copies of the type variables so that we can instantiate them. We could do this by passing in a mapping function but the problem is that if we have a type variable that gets unified to another variable we will not map it properly if it occurs again (we call "eventual" and get the second tv before calling the map function so we get a second copy and not the first copy). *) val (copiedCandidate : types, _) = generalise candidate; in case unifyTypes (copiedCandidate, copiedTarget) of NONE => (* Succeeded. Return the unified type. Either will do. *) MatchSuccess copiedTarget | SOME error => MatchError error end; (* Check that a matching has succeeded, and check the value constructors if they are datatypes. *) fun checkTypeConstrs (candidSet as TypeConstrSet(candid, candidConstrs), targetSet as TypeConstrSet(target, targetConstrs), targTypeMap: int -> typeId option, lex, near, lno, typeEnv, structPath) = let val candidName : string = tcName candid; val targetName : string = tcName target; val tvars = List.map TypeVar (tcTypeVars target); (* either will do *) (* If we get an error in the datatype itself print the full datatype. *) val printTypeEnv = { lookupType = fn _ => NONE, lookupStruct = fn _ => NONE } val errorInDatatype = sigStructMatchMsg(lex, near, lno, structPath)(fn t => displayTypeConstrs(t, errorDepth lex, printTypeEnv)) in if tcArity candid <> tcArity target then () (* Have already given the error message. *) else (* Check the type constructors themselves first. This checks that the sharing constraints have been satisfied. *) case matchTypes (mkTypeConstruction (candidName, candid, tvars, []), mkTypeConstruction (targetName, target, tvars, []), targTypeMap, lex) of MatchError error => (* Report the error. *) errorInDatatype(candidSet, targetSet, matchErrorReport(lex, typeEnv, typeEnv) error) | MatchSuccess _ => (* We have already checked for matching a type in the structure to a datatype in the signature. In ML97 we can't rebind an identifier in a signature so each constructor for this datatype must be present in the signature i.e. it can't be hidden by a constructor for another datatype. So we can check the types of the constructors when we check the values. We still need to check that if this has constructors that the candidate does not have more constructors. *) if null targetConstrs then () (* Target is just a type: this isn't a problem. *) else if List.length candidConstrs <= List.length targetConstrs then () (* If it's less then it will be picked up later. *) else let fun checkConstrs(Value{name=candidConstrName, ...}) = if List.exists(fn Value{name, ...} => name=candidConstrName) targetConstrs then () else errorNear(lex, true, near, lno, concat["Error while matching datatype ", candidName, ": constructor ", candidConstrName, " was present in the structure but not in the signature."]); in List.app checkConstrs candidConstrs end end (* Check that a candidate signature (actually the environment part of a structure) matches a target signature. The direction is important because a candidate is allowed to have more components and more polymorphism than the target. As part of the matching process we build up a map of typeIDs in the target to type IDs in the candidate and that is returned as the result. N.B. the map function takes an argument between minTarget and maxTarget. *) fun matchSigs(originalCandidate, originalTarget, near, lno, lex, typeIdEnv, typeEnv) :(int -> typeId) * (int * valueMatching) list = let val candidate = (* The structure. *) let val Signatures { typeIdMap, firstBoundIndex, boundIds, ... } = originalCandidate val _ = case boundIds of [] => () | _ => raise InternalError "Candidate structure with non-empty bound ID list" in if isUndefinedSignature originalCandidate then undefinedSignature else replaceMap(originalCandidate, typeIdMap, firstBoundIndex, [], typeIdEnv) end val target = (* The signature. *) let val Signatures { typeIdMap, firstBoundIndex, boundIds, ... } = originalTarget fun newMap n = if n < firstBoundIndex then typeIdEnv n else List.nth(boundIds, n-firstBoundIndex) in replaceMap(originalTarget, typeIdMap, firstBoundIndex, boundIds, newMap) end local val minTarget = sigMinTypes target and maxTarget = sigMaxTypes target (* All the Bound type IDs in the target are in this range. We create an array to contain the matched IDs from the candidate. *) val matchArray = Array.array(maxTarget-minTarget, NONE) in (* These two functions are used during the match process. *) (* When looking up a Bound ID we return NONE if it is out of the range. Bound IDs below the minimum are treated as global at this level and so only match if they are the same in the target and candidate. *) fun lookupType n = if n < minTarget then NONE else Array.sub(matchArray, n-minTarget) and enterType (n, id) = if n < minTarget then () else Array.update(matchArray, n-minTarget, SOME id) (* This is the result function. If everything is right every entry in the array will be SOME but if we have had an error there may be entries that are still NONE. To prevent an exception we return the undefined type in that case. *) fun resultType n = getOpt(Array.sub(matchArray, n-minTarget), tcIdentifier undefConstr) end (* Match typeIDs for types. This is slightly more complicated than simply assigning the stamps. *) fun matchNames (candidate, target, structPath) : unit = if isUndefinedSignature candidate then () (* Suppress unnecessary messages. *) else univFold (sigTab target, fn (dName, dVal, ()) => if tagIs typeConstrVar dVal then let (* See if there is one with the same name. *) val targetSet as TypeConstrSet(target, targetConstrs) = tagProject typeConstrVar dVal; val printTypeEnv = { lookupType = fn _ => NONE, lookupStruct = fn _ => NONE } fun displayType t = displayTypeConstrs(t, errorDepth lex, printTypeEnv) val typeError = sigStructMatchMsg(lex, near, lno, structPath) displayType in (* Match up the types. This does certain checks but does not check sharing. Equality is checked for. *) case univLookup (sigTab candidate, typeConstrVar, dName) of SOME (candidSet as TypeConstrSet(candid, candidConstrs)) => if not (isUndefinedTypeConstr target) (* just in case *) then ( (* Check for arity and equality - value constructors are checked later. If the target is a bound identifier in the range it can be matched by a candidate. *) case tcIdentifier target of TypeId{idKind=Bound { offset, ...}, ...} => enterType (offset, tcIdentifier candid) | _ => (); if tcArity target <> tcArity candid then typeError(candidSet, targetSet, PrettyString "Types take different numbers of type arguments.") (* Check that it's a datatype before checking for eqtype. *) else if not (null targetConstrs) andalso null candidConstrs then typeError(candidSet, targetSet, PrettyString "Type in structure is not a datatype") else if not(tcIsAbbreviation target) andalso tcEquality target andalso not (permitsEquality candid) then typeError(candidSet, targetSet, PrettyString "Type in structure is not an equality type") else () ) else () | NONE => sigStructMissingMsg(lex, near, lno, structPath) displayType targetSet end else if tagIs structVar dVal then let (* and sub-structures. *) val target = (tagProject structVar) dVal; (* For each target structure: find a candidate with the same name and recursively check them. *) in case univLookup (sigTab candidate, structVar, dName) of SOME candid => matchNames (structSignat candid, structSignat target, structPath ^ dName ^ ".") | NONE => let fun displayStructure s = PrettyBlock(0, false, [], [PrettyString "structure" , PrettyBreak(1, 3), PrettyString(structName s)]) in sigStructMissingMsg(lex, near, lno, structPath) displayStructure target end end else (), (* not a type or structure *) () (* default value for fold *) ) (* matchNames *); val () = matchNames (candidate, target, ""); (* Match the values and exceptions in the signatures. This actually does the checking of types. *) fun matchVals (candidate, target, structPath): (int * valueMatching) list = if isUndefinedSignature candidate then [] (* Suppress unnecessary messages. *) else (* Map the identifiers first, returning the originals if they are not in the map. *) let local fun matchStructures(dName, dVal, matches) = if tagIs typeConstrVar dVal then (* Types *) let (* For each type in the target ... *) val target = tagProject typeConstrVar dVal in (* Find a candidate with the same name. *) case univLookup (sigTab candidate, typeConstrVar, dName) of SOME candid => let (* We don't actually check the value constructors here, just load them if they match. Because of the no-redefinition rule value constructors in the signature must also be present in the value environment so we check them there. *) fun matchConstructor(source as Value{typeOf, ...}, Value{access=Formal addr, ...}, matches) = (addr, ValueMatch { sourceValue = source, coercion = NoCoercion, targetType = typeOf }) :: matches | matchConstructor(_, _, matches) = matches in (* Now check that the types match. *) checkTypeConstrs(candid, target, lookupType, lex, near, lno, typeEnv, structPath); ListPair.foldl matchConstructor matches (tsConstructors candid, tsConstructors target) end | NONE => matches (* If the lookup failed ignore the error - we've already reported it in matchNames *) end else if tagIs structVar dVal then let (* and each sub-structure *) val target = tagProject structVar dVal in (* For each target structure: find a candidate with the same name and recursively check them. *) case univLookup (sigTab candidate, structVar, dName) of SOME candid => let val substructMatch = matchVals (structSignat candid, structSignat target, structPath ^ dName ^ ".") in (* Produce the match instructions for the sub-structure. We only include Formal entries here. It's possible that there might be Global entries in some circumstances. *) case target of Struct{access=Formal addr, ...} => (addr, StructureMatch{ sourceStructure=candid, contentsMatch = substructMatch}) :: matches | _ => matches end | NONE => matches (* Ignore the error - we've already reported it in matchNames *) end else matches; in val structureMatches = univFold(sigTab target, matchStructures, []) end fun displayValue(value as Value {name, locations, typeOf, ...}) = let val decLocation = case List.find (fn DeclaredAt _ => true | _ => false) locations of SOME(DeclaredAt loc) => [ContextLocation loc] | _ => [] val valName = PrettyBlock(0, false, decLocation, [PrettyString name]) fun dispVal(kind, typeof) = PrettyBlock(0, false, [], [ PrettyString kind, PrettyBreak(1, 3), valName, PrettyBreak(0, 0), PrettyString(":"), PrettyBreak(1, 0), display (typeof, errorDepth lex, typeEnv) ]) in case value of Value{class=Constructor _, ...} => (* When displaying the constructor show the function type. We may have rebound the constructor in the candidate structure so that it creates a different datatype. *) dispVal("constructor", typeOf) | Value{class=Exception, ...} => PrettyBlock(0, false, [], PrettyString "exception" :: PrettyBreak(1, 3) :: valName :: ( case getFnArgType typeOf of NONE => [] | SOME excType => [ PrettyBreak (1, 1), PrettyString "of", PrettyBreak (1, 3), display (excType, errorDepth lex, typeEnv) ] )) | _ => dispVal("val", typeOf) end local fun matchLocalValues(dName, dVal, matches) = if tagIs valueVar dVal then let val destVal as Value { typeOf=destTypeOf, class=destClass, access=destAccess, ...} = tagProject valueVar dVal in case univLookup (sigTab candidate, valueVar, dName) of NONE => (sigStructMissingMsg(lex, near, lno, structPath) displayValue destVal; matches) | SOME (candid as Value { typeOf=sourceTypeOf, class=sourceClass, ...}) => let (* If the target is a constructor or exception the candidate must be similar. If the candidate is a constructor or exception this will match a value but requires some coercion. *) datatype matchType = IsOK of valueCoercions | IsWrong of pretty val matchKind = case (destClass, sourceClass) of (Constructor _, Constructor _) => IsOK NoCoercion | (Constructor _, _) => IsWrong(PrettyString "Value is not a constructor") | (Exception, Exception) => IsOK NoCoercion | (Exception, _) => IsWrong(PrettyString "Value is not an exception") | (_, Exception) => IsOK ExceptionToValue | (_, Constructor _) => IsOK ConstructorToValue | _ => IsOK NoCoercion in case matchKind of IsWrong error => ( sigStructMatchMsg(lex, near, lno, structPath) displayValue (candid, destVal, error); matches ) | IsOK coercion => case matchTypes (sourceTypeOf, destTypeOf, lookupType, lex) of MatchSuccess instanceType => ( (* If it matches an entry in the signature it counts as being exported and therefore referenced. *) case candid of Value { references=SOME{exportedRef, ...}, ...} => exportedRef := true | _ => (); (* Add the instance type to the instance types. *) case candid of Value{ instanceTypes=SOME instanceRef, ...} => (* This has to be generalised before it is added here. Unlike normal unification when matching to a signature any polymorphic variables in the target will not have been generalised. *) instanceRef := #1(generalise instanceType) :: !instanceRef | _ => (); case destAccess of Formal destAddr => (destAddr, ValueMatch { sourceValue = candid, coercion = coercion, targetType = instanceType }) :: matches | _ => matches (* This could be global. *) ) | MatchError error => ( sigStructMatchMsg(lex, near, lno, structPath) displayValue (candid, destVal, matchErrorReport(lex, typeEnv, typeEnv) error); matches ) end end else matches in val matchedValues = univFold(sigTab target, matchLocalValues, structureMatches) end in matchedValues end (* matchVals *); val doMatch = matchVals (candidate, target, ""); (* Do the match. *) in (resultType, doMatch) (* Return the function to look up the results. *) end (* matchSigs *); val makeEnv = fn x => let val Env e = makeEnv x in e end; (* Any values in the signature are counted as exported. This case applies if there was no result signature because if there was a signature the values would have been given their references and types in the signature matching. *) fun markValsAsExported resSig = let fun refVals(_, dVal, ()) = if tagIs valueVar dVal then let val valu = tagProject valueVar dVal in case valu of Value {references=SOME{exportedRef, ...}, ...} => exportedRef := true | _ => (); (* If we have exported the value without a signature we use the most general type and discard any, possibly less general, references. *) case valu of Value{ typeOf, instanceTypes=SOME instanceRef, ...} => instanceRef := [#1(generalise typeOf)] | _ => () end else () in univFold(sigTab resSig, refVals, ()) end (* Construct a set of actions for matching a structure to itself. This is only really needed to ensure that type IDs are passed through correctly but we don't actually do them here yet. *) fun makeCopyActions signat : (int * valueMatching) list = let fun matchEntry(_, dVal, matches) = if tagIs structVar dVal then let val str = tagProject structVar dVal in case str of Struct{access=Formal addr, ...} => (addr, StructureMatch{ sourceStructure=str, contentsMatch = makeCopyActions(structSignat str)}) :: matches | _ => matches end else if tagIs valueVar dVal then let val v = tagProject valueVar dVal in case v of Value { access=Formal addr, typeOf, ...} => (addr, ValueMatch { sourceValue = v, coercion = NoCoercion, targetType = typeOf }) :: matches | _ => matches end else if tagIs typeConstrVar dVal then let fun matchConstructor(v as Value{access=Formal addr, typeOf, ...}, matches) = (addr, ValueMatch { sourceValue = v, coercion = NoCoercion, targetType = typeOf }) :: matches | matchConstructor(_, matches) = matches in List.foldl matchConstructor matches (tsConstructors(tagProject typeConstrVar dVal)) end else matches in univFold(sigTab signat, matchEntry, []) end (* Actions to copy the type Ids into the result signature. *) local fun matchTypeIds(_, []) = [] | matchTypeIds(n, (typeId as TypeId{ access = Formal addr, ...}) :: rest) = (addr, TypeIdMatch{ sourceIdNo=n, isEquality=isEquality typeId }) :: matchTypeIds(n+1, rest) | matchTypeIds(_, _) = raise InternalError "matchTypeIds: Not Formal" in fun makeMatchTypeIds destIds = matchTypeIds(0, destIds) end (* Second pass - identify names with values and type-check *) (* Process structure-returning expressions i.e. structure names, struct..end values and functor applications. *) fun structValue(str: structValue, newTypeId: (int*bool*bool*bool*typeIdDescription)->typeId, currentTypeCount, newTypeIdEnv: unit -> int->typeId, Env env, lex, lno, structPath) = let val typeEnv = { lookupType = fn s => case #lookupType env s of NONE => NONE | SOME t => SOME(t, SOME(newTypeIdEnv())), lookupStruct = fn s => case #lookupStruct env s of NONE => NONE | SOME t => SOME(t, SOME(newTypeIdEnv())) } in case str of StructureIdent {name, valRef, location} => let (* Look up the name and save the value. *) val result = lookupStructure ("Structure", {lookupStruct = #lookupStruct env}, name, giveError (str, location, lex)) val () = valRef := result in case result of SOME(Struct{signat, ...}) => signat | NONE => undefinedSignature end | FunctorAppl {name, arg, valRef, nameLoc, fullLoc, argIds, resIds, matchToArgument, ... } => (* The result structure must be copied to generate a new environment. This will make new types so that different applications of the functor yield different types. There may be dependencies between the parameters and result signatures so copying may have to take that into account. *) ( case #lookupFunct env name of NONE => ( giveError (str, nameLoc, lex) ("Functor (" ^ name ^ ") has not been declared"); undefinedSignature ) | SOME functr => let val Functor { arg = Struct{signat=formalArgSig, ...}, result=functorResSig, ...} = functr val () = valRef := SOME functr (* save it till later. *) (* Apply a functor to an argument. The result structure contains a mixture of IDs from the argument structure and generative IDs from the result structure. There are two parts to this process. 1. We have to match the actual argument structure to the formal argument to ensure that IDs are in the right place for the functor. 2. We have to take the actual argument structure and the functor result structure and produce a combination of this as a structure. *) (* IDs: argIDs: A list of pairs of IDs as Selected/Local/Global values and Formal values. This contains the IDs that must be passed into the functor. resIDs: A list of pairs of IDs as Local values and Formal values. The Local value is the location where a new generative ID is stored and the Formal offset is the offset within the run-time vector returned by the signature where the source ID for the generative ID is to be found. *) (* This provides information about the arguments. *) (* Get the actual parameter value. *) val actualArgSig = structValue(arg, newTypeId, currentTypeCount, newTypeIdEnv, Env env, lex, fullLoc, structPath); local (* Check that the actual arguments match formal arguments, and instantiate the variables. *) val (matchResults, matchActions) = matchSigs (actualArgSig, formalArgSig, fn n => displayStructValue(str, n), fullLoc, lex, newTypeIdEnv(), typeEnv); (* Record the code to match to this and include instructions to load the typeIDs. *) val () = matchToArgument := matchActions @ makeMatchTypeIds(sigBoundIds formalArgSig) in val matchResults = matchResults end (* Create a list of the type IDs that the argument must supply. *) local val maxT = sigMaxTypes formalArgSig and minT = sigMinTypes formalArgSig val results = List.tabulate(maxT-minT, fn n => matchResults(n+minT)) val args = ListPair.mapEq(fn(s, d) => { source = s, dest = d })(results, sigBoundIds formalArgSig) in val () = argIds := args; (* Save for code-generation. *) end (* Now create the generative typeIDs. These are IDs that are in the bound ID range of the result signature. Any type IDs inherited from the argument will have type ID values less than sigMinTypes functorResSig. *) local fun makeNewTypeId( oldId as TypeId{idKind=Bound{isDatatype, arity, ...}, description = { name=oldName, ...}, ...}) = let val description = { location = fullLoc, name = oldName, description = "Created from applying functor " ^ name } val newId = newTypeId(arity, false, isEquality oldId, isDatatype, description) in { source = oldId, dest = newId } end | makeNewTypeId _ = raise InternalError "Not Bound" (* The resIds list tells the code-generator where to find the source of each ID in the result structure and where to save the generative ID. *) val sdList = List.map makeNewTypeId (sigBoundIds functorResSig) val _ = resIds := sdList (* Save for code-generation. *) in (* This vector contains the resulting type IDs. They all have Local access. *) val resVector = Vector.fromList(List.map(fn { dest, ...} => dest) sdList) end (* Construct a result signature. This will contain all the IDs created here i.e. IDs in the argument and generative IDs at the start and then all the values and structures returned from the functor. When we come to code-generate we need to 1. Use loadOpaqueIds over the resIDs to create the opaque IDs. 2. Basically, do the same as StructDec to match to the result signature. We don't need to do anything about type IDs from the argument. Processing the argument will ensure that type IDs created in the argument are declared as Locals and if we pass localIDs to matchStructure we will load IDs from both the argument and generative IDs created by loadOpaqueIds. *) val minCopy = Int.min(sigMinTypes formalArgSig, sigMinTypes functorResSig) val idEnv = newTypeIdEnv() fun getCombinedTypeId n = if n < minCopy then idEnv n else if n >= sigMinTypes functorResSig then Vector.sub(resVector, n - sigMinTypes functorResSig) else if n >= sigMinTypes formalArgSig then matchResults n else sigTypeIdMap formalArgSig n val resSig = let val Signatures { name, tab, locations, ... } = functorResSig in makeSignature(name, tab, currentTypeCount(), locations, composeMaps(sigTypeIdMap functorResSig, getCombinedTypeId), []) end in resSig end ) | StructDec {alist, location, matchToResult, ...} => let (* Collection of declarations packaged into a structure or a collection of signatures. *) (* Some of the environment, the types and the value constructors, is generated during the first pass. Get the environment from the structure. *) val structTable = makeSignatureTable () val structEnv = makeEnv structTable val makeLocalTypeId = newTypeId val makeLocalTypeIdEnv = newTypeIdEnv val newEnv = { enterType = #enterType structEnv, enterVal = #enterVal structEnv, enterStruct = #enterStruct structEnv, enterSig = fn _ => raise InternalError "Signature in Struct End", enterFunct = fn _ => raise InternalError "Functor in Struct End", lookupVal = lookupDefault (#lookupVal structEnv) (#lookupVal env), lookupType = lookupDefault (#lookupType structEnv) (#lookupType env), lookupStruct = lookupDefault (#lookupStruct structEnv) (#lookupStruct env), lookupSig = #lookupSig env, (* Global *) lookupFunct = #lookupFunct env, (* Global *) lookupFix = #lookupFix env, (* Fixity declarations are dealt with in the parsing process. They are only processed again in this pass in order to get declarations in the right order. *) enterFix = fn _ => (), allValNames = fn () => (#allValNames structEnv () @ #allValNames env ()) } (* process body of structure *) val () = pass2Struct (alist, makeLocalTypeId, currentTypeCount, makeLocalTypeIdEnv, Env newEnv, lex, lno, structPath); (* We need to make a signature for the result in the form that can be used if there is no explicit signature, for example if this is used as the result of a functor. That means creating Formal values for all the values and structures. These Formal entries define the position in the run-time vector where each of the values and sub-structures are located. We don't include typeIDs in this. Any typeIDs that need to be included in the run-time vector are added by the functor declaration code. *) val finalTable = makeSignatureTable(); val finalEnv = makeEnv finalTable (* Create the result signature and also build the match structure to match to it. *) fun enterItem(dName, dVal, (addrs, matches)) = if tagIs typeConstrVar dVal then let val tConstr as TypeConstrSet(typConstr, valConstrs) = tagProject typeConstrVar dVal in if null valConstrs then (#enterType finalEnv (dName, tConstr); (addrs, matches)) else let (* If this is a datatype constructor convert the value constructors. The "no redefinition" rule for signatures doesn't apply to a structure so the signature we create here could have some constructors that have been hidden by later declarations. We still need the whole value environment in case of datatype replication. *) fun convertConstructor( valVal as Value{class, typeOf, locations, references, name, instanceTypes, ...}, (otherConstrs, (addrs, matches))) = let val formalValue = Value{class=class, name=name, typeOf=typeOf, access=Formal addrs, locations=locations, references=references, instanceTypes=instanceTypes} in (formalValue :: otherConstrs, (addrs + 1, (addrs, ValueMatch { sourceValue = valVal, coercion = NoCoercion, targetType=typeOf}) :: matches)) end val (newConstrs, newAddrMatch) = List.foldl convertConstructor ([], (addrs, matches)) valConstrs val newConstructor = makeTypeConstructor( tcName typConstr, tcTypeVars typConstr, tcIdentifier typConstr, tcLocations typConstr) in #enterType finalEnv (dName, TypeConstrSet(newConstructor, List.rev newConstrs)); newAddrMatch end end else if tagIs structVar dVal then let val strVal = tagProject structVar dVal val locations = structLocations strVal val strSig = structSignat strVal val matchSubStructure = makeCopyActions strSig in #enterStruct finalEnv (dName, makeFormalStruct (dName, strSig, addrs, locations)); (addrs + 1, (addrs, StructureMatch { sourceStructure=strVal, contentsMatch = matchSubStructure}) :: matches) end else if tagIs valueVar dVal then let val valVal = tagProject valueVar dVal in (* If this is a type-dependent function such as PolyML.print we must put in the original type-dependent version not the version which will have frozen its type as 'a. *) case valVal of value as Value{access = Overloaded _, ...} => ( #enterVal finalEnv (dName, value); (addrs, matches) ) | Value{class, typeOf, locations, references, instanceTypes, ...} => let val formalValue = Value{class=class, name=dName, typeOf=typeOf, access=Formal addrs, locations=locations, references=references, instanceTypes=instanceTypes} in #enterVal finalEnv (dName, formalValue); (addrs + 1, (addrs, ValueMatch { sourceValue = valVal, coercion = NoCoercion, targetType=typeOf}) :: matches) end end else (addrs, matches) val () = matchToResult := #2(univFold(structTable, enterItem, (0, []))) val locations = [DeclaredAt location, SequenceNo (newBindingId lex)] val resSig = makeSignature("", finalTable, currentTypeCount(), locations, newTypeIdEnv(), []) in resSig end | LetDec {decs, body = localStr, line, ...} => let (* let strdec in strexp end *) val newEnv = makeEnv (makeSignatureTable()); (* The environment for the local declarations. *) val localEnv = { lookupVal = lookupDefault (#lookupVal newEnv) (#lookupVal env), lookupType = lookupDefault (#lookupType newEnv) (#lookupType env), lookupFix = #lookupFix newEnv, lookupStruct = lookupDefault (#lookupStruct newEnv) (#lookupStruct env), lookupSig = #lookupSig env, lookupFunct = #lookupFunct env, (* Sigs and functs are global *) enterVal = #enterVal newEnv, enterType = #enterType newEnv, (* Fixity declarations are dealt with in the parsing process. At this stage we simply need to make sure that local declarations aren't entered into the global environment. *) enterFix = fn _ => (), enterStruct = #enterStruct newEnv, enterSig = #enterSig newEnv, enterFunct = #enterFunct newEnv, allValNames = fn () => (#allValNames newEnv () @ #allValNames env ()) }; (* Process the local declarations. *) val () = pass2Struct (decs, newTypeId, currentTypeCount, newTypeIdEnv, Env localEnv, lex, line, structPath); in (* There should just be one entry in the "body" list. *) structValue(localStr, newTypeId, currentTypeCount, newTypeIdEnv, Env localEnv, lex, line, structPath) end | SigConstraint { str, csig, opaque, sigLoc, opaqueIds, matchToConstraint, ... } => let val bodyIds = ref [] val startTypes = currentTypeCount() val startTypeEnv = newTypeIdEnv() fun sconstraintMakeTypeId (arity, isVar, eq, isdt, desc) = let val newId = newTypeId(arity, isVar, eq, isdt, desc) in bodyIds := newId :: ! bodyIds; newId end fun sconstraintTypeIdEnv () n = if n < startTypes then startTypeEnv n else valOf( List.find(fn TypeId{idKind=Bound{offset, ...}, ...} => offset = n | _ => raise Subscript) (!bodyIds)) val resSig = structValue(str, sconstraintMakeTypeId, currentTypeCount, sconstraintTypeIdEnv, Env env, lex, lno, structPath); (* Get the explicit signature. *) val explicitSig = sigVal(csig, startTypes, startTypeEnv, Env env, lex, sigLoc) val minExplicitSig = sigMinTypes explicitSig and maxExplicitSig = sigMaxTypes explicitSig (* Match the signature. This instantiates entries in typeMap. *) val (matchResults, matchActions) = matchSigs (resSig, explicitSig, fn n => displayStructValue(str, n), sigLoc, lex, startTypeEnv, typeEnv); val () = matchToConstraint := matchActions val rSig = if opaque then let (* Construct new IDs for the generic IDs. For each ID in the signature we need to make a new Local ID. *) fun makeNewId(oldId as TypeId{idKind=Bound{ isDatatype, arity, ...}, description = { name, ...}, ...}) = let val description = { location = sigLoc, name = name, description = "Created from opaque signature" } in newTypeId(arity, false, isEquality oldId, isDatatype, description) end | makeNewId _ = raise InternalError "Not Bound" val sources = List.tabulate(maxExplicitSig-minExplicitSig, fn n => matchResults(n+minExplicitSig)) val dests = List.map makeNewId (sigBoundIds explicitSig) (* Add the matching IDs to a list. When we create the code for the structure we need to create new run-time ID values using the original equality code and a new ref to hold the printer. *) val () = opaqueIds := ListPair.mapEq (fn (s, d) => { source=s, dest=d }) (sources, dests) (* Create new IDs for all the bound IDs in the signature. *) val v = Vector.fromList dests (* And copy it to put in the names from the structure. *) val currentEnv = newTypeIdEnv() fun oldMap n = if n < minExplicitSig then currentEnv n else Vector.sub (v, n - minExplicitSig) val Signatures{locations, name, tab, typeIdMap, ...} = explicitSig in makeSignature(name, tab, currentTypeCount(), locations, composeMaps(typeIdMap, oldMap), []) end else (* Transparent: Use the IDs from the structure. *) let val newIdEnv = newTypeIdEnv () fun matchedIds n = if n < sigMinTypes explicitSig then newIdEnv n else matchResults n val Signatures{locations, name, tab, typeIdMap, ...} = explicitSig in (* The result signature. This needs to be able to enumerate the type IDs including those we've added. *) makeSignature(name, tab, currentTypeCount(), locations, composeMaps(typeIdMap, matchedIds), []) end in rSig end end (* structValue *) and pass2Struct (strs : structDec list, makeLocalTypeId : (int * bool * bool * bool * typeIdDescription) -> typeId, makeCurrentTypeCount: unit -> int, makeTypeIdEnv: unit -> int -> typeId, Env env : env, lex, lno : LEX.location, structPath: string ) : unit = let fun pass2StructureDec (str : structDec, structList : structBind list, typeIdsForDebug) : unit = let (* Declaration of structures. *) (* The declarations must be made in parallel. i.e. structure A = struct ... end and B = A; binds B to the A in the PREVIOUS environment, not the A being declared. *) val sEnv = (* The new names. *) noDuplicates (fn(name, _, _) => errorNear (lex, true, fn n => displayStruct(str, n), lno, "Structure " ^ name ^ " has already been bound in this declaration") ) (* Any new type Ids we create need to be added onto a list in case we need them for the debugger. *) fun captureIds args = let val id = makeLocalTypeId args in typeIdsForDebug := id :: ! typeIdsForDebug; id end (* Put the new names into this environment. *) fun pass2StructureBind ({name, value, valRef, line, nameLoc, ...}) : unit= let (* Each element in the list is a structure binding. *) val resSig = structValue(value, captureIds, makeCurrentTypeCount, makeTypeIdEnv, Env env, lex, line, structPath ^ name ^ "."); (* Any values in the signature are counted as exported. *) val () = markValsAsExported resSig; (* Now make a local structure variable using this signature. *) val locations = [DeclaredAt nameLoc, SequenceNo (newBindingId lex)] val var = makeLocalStruct (name, resSig, locations) in #enter sEnv (name, var); valRef := SOME var end in List.app pass2StructureBind structList; (* Put them into the enclosing env. *) #apply sEnv (#enterStruct env) end; (* pass2StructureDec *) fun pass2Localdec (decs : structDec list, body : structDec list) : unit = let val newEnv = makeEnv (makeSignatureTable()); (* The environment for the local declarations. *) val localEnv = { lookupVal = lookupDefault (#lookupVal newEnv) (#lookupVal env), lookupType = lookupDefault (#lookupType newEnv) (#lookupType env), lookupFix = #lookupFix newEnv, lookupStruct = lookupDefault (#lookupStruct newEnv) (#lookupStruct env), lookupSig = #lookupSig env, lookupFunct = #lookupFunct env, enterVal = #enterVal newEnv, enterType = #enterType newEnv, enterFix = fn _ => (), enterStruct = #enterStruct newEnv, enterSig = #enterSig newEnv, enterFunct = #enterFunct newEnv, allValNames = fn () => (#allValNames newEnv () @ #allValNames env ()) }; (* Process the local declarations. *) val () = pass2Struct (decs, makeLocalTypeId, makeCurrentTypeCount, makeTypeIdEnv, Env localEnv, lex, lno, structPath); (* This is the environment used for the body of the declaration. Declarations are added both to the local environment and to the surrounding scope. *) (* Look-ups come from the local env *) val bodyEnv = { lookupVal = #lookupVal localEnv, lookupType = #lookupType localEnv, lookupFix = #lookupFix localEnv, lookupStruct = #lookupStruct localEnv, lookupSig = #lookupSig localEnv, lookupFunct = #lookupFunct localEnv, enterVal = fn pair => ( #enterVal newEnv pair; #enterVal env pair ), enterType = fn pair => ( #enterType newEnv pair; #enterType env pair ), enterFix = #enterFix localEnv, enterStruct = fn pair => ( #enterStruct newEnv pair; #enterStruct env pair ), enterSig = fn pair => ( #enterSig newEnv pair; #enterSig env pair ), enterFunct = #enterFunct localEnv, allValNames = #allValNames localEnv }; in (* Now the body. *) pass2Struct (body, makeLocalTypeId, makeCurrentTypeCount, makeTypeIdEnv, Env bodyEnv, lex, lno, structPath) end; (* pass2Localdec *) fun pass2Singleton (dec : parsetree, vars) : unit = let (* Single declaration - may declare several names. *) (* As well as entering the declarations we must keep a list of the value and exception declarations. *) val newEnv = { lookupVal = #lookupVal env, lookupType = #lookupType env, lookupFix = #lookupFix env, lookupStruct = #lookupStruct env, lookupSig = #lookupSig env, lookupFunct = #lookupFunct env, (* Must add the entries onto the end in case a declaration with the same name is made. e.g. local ... in val a=1; val a=2 end. *) enterVal = fn (pair as (_,v)) => ( #enterVal env pair; vars := !vars @ [CoreValue v] ), enterType = fn (pair as (_,t)) => ( #enterType env pair; vars := !vars @ [CoreType t] ), enterFix = fn pair => ( #enterFix env pair; vars := !vars @ [CoreFix pair] ), (* This will only be used if we do `open A' where A contains sub-structures. *) enterStruct = fn (pair as (_,v)) => ( #enterStruct env pair; vars := !vars @ [CoreStruct v] ), enterSig = #enterSig env, enterFunct = #enterFunct env, allValNames = #allValNames env }; (* Create a new type ID for each new datatype. Add the structure path to the name. *) fun makeId (eq, isdt, (args, EmptyType), { location, name, description }) = makeLocalTypeId(List.length args, true, eq, isdt, { location = location, name = structPath ^ name, description = description }) | makeId (_, _, (typeVars, decType), { location, name, description }) = makeTypeFunction( { location = location, name = structPath ^ name, description = description }, (typeVars, decType)) (* Process the body and discard the type. *) val _ : types = pass2 (dec, makeId, Env newEnv, lex, fn _ => false); in () end (* pass2Singleton *) fun pass2Dec (str as StructureDec { bindings, typeIdsForDebug, ... }) = pass2StructureDec (str, bindings, typeIdsForDebug) | pass2Dec(Localdec {decs, body, ...}) = pass2Localdec (decs, body) | pass2Dec(CoreLang {dec, vars, ...}) = pass2Singleton (dec, vars) in List.app pass2Dec strs (* Process all the top level entries. *) end (* pass2Struct *) fun pass2Structs ((strs, _): program, lex : lexan, Env globals : env) : unit = let (* Create a local environment to capture declarations. We don't want to add them to the global environment at this point. *) val newValEnv = UTILITIES.searchList() and newTypeEnv = UTILITIES.searchList() and newStrEnv = UTILITIES.searchList() and newSigEnv = UTILITIES.searchList() and newFuncEnv = UTILITIES.searchList() val lookupVal = lookupDefault (#lookup newValEnv) (#lookupVal globals) and lookupType = lookupDefault (#lookup newTypeEnv) (#lookupType globals) and lookupStruct = lookupDefault (#lookup newStrEnv) (#lookupStruct globals) and lookupSig = lookupDefault (#lookup newSigEnv) (#lookupSig globals) and lookupFunct = lookupDefault (#lookup newFuncEnv) (#lookupFunct globals) fun allValNames () = let val v = ref [] val () = #apply newValEnv (fn (s, _) => v := s :: ! v) in !v @ #allValNames globals () end val env = { lookupVal = lookupVal, lookupType = lookupType, lookupFix = #lookupFix globals, lookupStruct = lookupStruct, lookupSig = lookupSig, lookupFunct = lookupFunct, enterVal = #enter newValEnv, enterType = #enter newTypeEnv, enterFix = fn _ => (), (* ?? Already entered by the parser. *) enterStruct = #enter newStrEnv, enterSig = #enter newSigEnv, enterFunct = #enter newFuncEnv, allValNames = allValNames }; (* Create the free identifiers. These are initially Bound but are replaced by Free after the code has been executed and we have the values for the printer and equality functions. They are only actually created in strdecs but functor or signature topdecs in the same program could refer to them. *) local val typeIds = ref [] in fun topLevelId(arity, isVar, eq, isdt, description) = let val idNumber = topLevelIdNumber() val newId = (if isVar then makeBoundIdWithEqUpdate else makeBoundId) (arity, Local{addr = ref ~1, level = ref baseLevel}, idNumber, eq, isdt, description) in typeIds := newId :: ! typeIds; newId end and topLevelIdNumber() = List.length(!typeIds) and makeTopLevelIdEnv() = (* When we process a topdec we create a top-level ID environment which matches any ID numbers we've already created in this "program" to the actual ID. Generally this will be empty. *) let val typeVec = Vector.fromList(List.rev(!typeIds)) in fn n => Vector.sub(typeVec, n) end end (* We have to check that a type does not contain free variables and turn them into unique monotypes if they exist. This is a bit messy. We have to allow subsequent structure declarations to freeze the types (there's an example on p90 of the Definition) but we can't functors to get access to unfrozen free variables because that can break the type system. *) fun checkValueForFreeTypeVariables(name: string, v: values) = checkForFreeTypeVariables(name, valTypeOf v, lex, codeForUniqueId) (* Find all the values in the structure. *) fun checkStructSigForFreeTypeVariables(name: string, s: signatures) = let fun checkEntry(dName: string, dVal: universal, ()) = if tagIs structVar dVal then checkStructSigForFreeTypeVariables(name ^ dName ^ ".", structSignat((tagProject structVar) dVal)) else if tagIs valueVar dVal then checkValueForFreeTypeVariables(name ^ dName, (tagProject valueVar) dVal) else () in univFold(sigTab s, checkEntry, ()) end fun checkVariables (newValEnv, newStrEnv) = ( #apply newValEnv (fn (s: string, v: values) => checkValueForFreeTypeVariables(s, v)); #apply newStrEnv ( fn (n: string, s: structVals) => checkStructSigForFreeTypeVariables(n^".", structSignat s)) ) fun pass2TopDec ([], envs) = List.app checkVariables envs | pass2TopDec (StrDec(str, typeIds)::rest, envs) = let (* Remember the top-level Ids created in this strdec. *) fun makeId(arity, isVar, eq, isdt, desc) = let val newId = topLevelId(arity, isVar, eq, isdt, desc) in typeIds := newId :: ! typeIds; newId end in (* strdec: structure or core-language topdec. *) pass2Struct([str], makeId, topLevelIdNumber, makeTopLevelIdEnv, Env env, lex, location lex, ""); pass2TopDec(rest, if errorOccurred lex then [] else (newValEnv, newStrEnv) :: envs) end | pass2TopDec((topdec as FunctorDec (structList : functorBind list, lno)) :: rest, envs) = let val () = List.app checkVariables envs (* Check previous variables. *) (* There is a restriction that the same name may not be bound twice. As with other bindings functor bindings happen in parallel. DCJM 6/1/00. *) val sEnv = (* The new names. *) noDuplicates (fn (name, _, _) => errorNear(lex, true, fn n => displayTopDec(topdec, n), lno, "Functor " ^ name ^ " has already been bound in this declaration") ); val startTopLevelIDs = topLevelIdNumber() and topLevelEnv = makeTopLevelIdEnv() (* Put the new names into this environment. *) fun pass2FunctorBind ({name, nameLoc, arg = {name = argName, sigStruct = argSig, valRef = argVal}, body, valRef, resIds, line, matchToResult, debugArgVals, debugArgStructs, debugArgTypeConstrs, ...}: functorBind) = let (* When we apply a functor we share type IDs with the argument if they have an ID less than sigMinTypes for the result signature and treat other IDs as generative. If we don't have an explicit result signature or if we have a transparent signature the type IDs in the result are those returned from the body. To keep the argument IDs separate from newly created IDs we start creating local IDs with offsets after the args. *) val typeStamps = ref startTopLevelIDs; val localStamps = ref [] val argumentSignature = sigVal (argSig, startTopLevelIDs, topLevelEnv, Env env, lex, line) (* TODO: The location here is the location of the argument id if there is one. nameLoc is the location of the name of the functor. *) val locations = [DeclaredAt nameLoc, SequenceNo (newBindingId lex)] val resArg = makeLocalStruct (argName, argumentSignature, locations) (* sigVal will have numbered the bound IDs to start at startTopLevelIDs. We need to enter these bound IDs into the local environment but as Selected entries. *) local fun mkId(TypeId{idKind=Bound{ arity, eqType, isDatatype, offset, ...}, description={ location, name, description}, access = Formal addr, ...}) = TypeId{idKind=Bound { arity = arity, offset = offset, eqType = eqType, isDatatype = isDatatype }, description = { location=location, (* Add the structure name to the argument type IDs. *) name=if argName = "" then name else argName^"."^name, description=description }, access = makeSelected(addr, resArg)} | mkId _ = raise InternalError "mkId: Not Bound or not Formal" in (* argIDVector is part of the environment now. *) val argIDVector = Vector.fromList(List.map mkId (sigBoundIds argumentSignature)) val () = typeStamps := !typeStamps + List.length(sigBoundIds argumentSignature) end val startBodyIDs = ! typeStamps; (* After the arguments. *) local (* We also have to apply the above map to the signature. Structures may not have Formal entries for their type IDs so we must map them to the Selected items. Actually, there's a nasty sort of circularity here; we'd like the Selected entries to use structArg as the base but we can't create it until we have its signature...which uses structArg. *) val argSigWithSelected = let val Signatures { tab, name, locations, typeIdMap, ...} = argumentSignature fun mapToSelected n = if n < startTopLevelIDs then topLevelEnv n else Vector.sub(argIDVector, n-startTopLevelIDs) in makeSignature(name, tab, startBodyIDs, locations, composeMaps(typeIdMap, mapToSelected), []) end in val argEnv = makeEnv (makeSignatureTable()); (* Local name space. *) (* We may either have a single named structure in which case that is the argument or effectively a sig...end block in which case we have to open a dummy structure. *) val () = if argName <> "" then (* Named structure. *) let val structArg = Struct { name = argName, signat = argSigWithSelected, access = structAccess resArg, locations=structLocations resArg } in debugArgStructs := [structArg]; #enterStruct argEnv (argName, structArg) end else (* Open the dummy argument. Similar to "open" in treestruct. *) COPIER.openSignature (argSigWithSelected, { enterType = fn (s,v) => (debugArgTypeConstrs := v :: ! debugArgTypeConstrs; #enterType argEnv (s, v)), enterStruct = fn (name, strVal) => let val argStruct = makeSelectedStruct (strVal, resArg, []) in debugArgStructs := argStruct :: ! debugArgStructs; #enterStruct argEnv (name, argStruct) end, enterVal = fn (name, value) => let val argVal = mkSelectedVar (value, resArg, []) in debugArgVals := argVal :: ! debugArgVals; #enterVal argEnv (name, argVal) end }, "") end val () = argVal := SOME resArg (* Now process the body of the functor using the environment of the arguments to the functor and the global environment. *) val envWithArgs = { lookupVal = lookupDefault (#lookupVal argEnv) (#lookupVal env), lookupType = lookupDefault (#lookupType argEnv) (#lookupType env), lookupFix = #lookupFix env, lookupStruct = lookupDefault (#lookupStruct argEnv) (#lookupStruct env), lookupSig = #lookupSig env, lookupFunct = #lookupFunct env, enterVal = #enterVal env, enterType = #enterType env, enterFix = fn _ => (), enterStruct = #enterStruct env, enterSig = #enterSig env, enterFunct = #enterFunct env, allValNames = fn () => (#allValNames argEnv () @ #allValNames env ()) }; local (* Create local IDs for any datatypes declared in the body or any generative functor applications. *) fun newTypeId(arity, isVar, eq, isdt, desc) = let val n = !typeStamps val () = typeStamps := n + 1; val newId = (if isVar then makeBoundIdWithEqUpdate else makeBoundId) (arity, Local{addr = ref ~1, level = ref baseLevel}, n, eq, isdt, desc) in localStamps := newId :: !localStamps; newId end fun typeIdEnv () = let val localIds = Vector.fromList(List.rev(! localStamps)) in fn n => if n < startTopLevelIDs then topLevelEnv n else if n < startBodyIDs then Vector.sub(argIDVector, n-sigMinTypes argumentSignature) else Vector.sub(localIds, n-startBodyIDs) end in val resSig = structValue(body, newTypeId, fn () => !typeStamps, typeIdEnv, Env envWithArgs, lex, line, "") val () = if errorOccurred lex then () else checkStructSigForFreeTypeVariables(name^"().", resSig) (* This counts as a reference. *) val () = markValsAsExported resSig end; local val startRunTimeOffsets = getNextRuntimeOffset resSig fun convertId(n, id as TypeId{idKind=Bound { offset, isDatatype, arity, ...}, description, ...}) = (* Either inherited from the argument or a new type ID. *) makeBoundId (arity, Formal(n + startRunTimeOffsets), offset, isEquality id, isDatatype, description) | convertId (_, id) = id (* Free or TypeFunction. *) val localVector = Vector.fromList(List.rev(!localStamps)) val bodyVec = Vector.mapi convertId localVector val Signatures { name, tab, typeIdMap, locations, ...} = resSig (* These local IDs are included in the bound ID range for the result signature. Since they were created in the functor new instances will be generated when the functor is applied. *) val newBoundIds = Vector.foldr (op ::) [] bodyVec (* Record the ID map for code-generation. *) val () = resIds := Vector.foldri(fn (n, b, r) => { source=b, dest=Vector.sub(bodyVec, n)} :: r) [] localVector fun resTypeMap n = if n < startTopLevelIDs then topLevelEnv n else if n < startBodyIDs then Vector.sub(argIDVector, n-sigMinTypes argumentSignature) else Vector.sub(bodyVec, n-startBodyIDs) in val functorSig = makeSignature(name, tab, startBodyIDs, locations, composeMaps(typeIdMap, resTypeMap), newBoundIds) val () = matchToResult := makeCopyActions functorSig @ makeMatchTypeIds newBoundIds end (* Now make a local functor variable and put it in the name space. Because functors can only be declared at the top level the only way it can be used is if we have functor F(..) = ... functor G() = ..F.. with no semicolon between them. They will then be taken as a single declaration and F will be picked up as a local. *) (* Set the size of the type map. *) val locations = [DeclaredAt nameLoc, SequenceNo (newBindingId lex)] val var = makeFunctor (name, resArg, functorSig, makeLocal (), locations) in #enter sEnv (name, var); valRef := SOME var end in (* Each element in the list is a functor binding. *) List.app pass2FunctorBind structList; (* Put them into the enclosing env. *) #apply sEnv (#enterFunct env); pass2TopDec(rest, []) end (* FunctorDec *) | pass2TopDec((topdec as SignatureDec (structList : sigBind list, lno)) :: rest, envs) = let val () = List.app checkVariables envs (* Check previous variables. *) (* There is a restriction that the same name may not be bound twice. As with other bindings functor bindings happen in parallel. DCJM 6/1/00. *) val sEnv = (* The new names. *) noDuplicates (fn (name, _, _) => errorNear (lex, true, fn n => displayTopDec(topdec, n), lno, "Signature " ^ name ^ " has already been bound in this declaration") ); val startTopLevelIDs = topLevelIdNumber() and topLevelEnv = makeTopLevelIdEnv() fun pass2SignatureBind ({name, nameLoc, sigStruct, line, sigRef, ...}) = let (* Each element in the list is a signature binding. *) val Signatures { tab, typeIdMap, firstBoundIndex, boundIds, ...} = sigVal (sigStruct, startTopLevelIDs, topLevelEnv, Env env, lex, line) val locations = [DeclaredAt nameLoc, SequenceNo (newBindingId lex)] val namedSig = (* Put in the signature name. *) makeSignature(name, tab, firstBoundIndex, locations, typeIdMap, boundIds) in sigRef := namedSig; (* Remember for pass4. *) #enter sEnv (name, namedSig) end in List.app pass2SignatureBind structList; (* Put them into the enclosing env. *) #apply sEnv (#enterSig env) ; pass2TopDec(rest, []) end in pass2TopDec(strs, []); (* Mark any exported values as referenced. *) #apply newValEnv (fn (s: string, valu: values) => ( (* If we have exported the value we need to mark it as a reference. But if the identifier has been rebound we only want to mark the last reference. Looking the identifier up will return only the last reference. *) case #lookup newValEnv s of SOME(Value { references=SOME{exportedRef, ...}, ...}) => exportedRef := true | _ => (); (* Since it's been exported the instance type is the most general type. We can discard any other instance type info since it cannot be more general. *) case valu of Value{ typeOf, instanceTypes=SOME instanceRef, ...} => instanceRef := [#1(generalise typeOf)] | _ => () ) ) end (*pass2Structs *); (* * * Code-generation phase. * * *) (* Generate code from the expressions and arrange to return the results so that "pass4" can find them. *) fun gencodeStructs ((strs, _), lex) = let (* Before code-generation perform an extra pass through the tree to remove unnecessary polymorphism. The type-checking computes a most general type for a value, typically a function, but it is frequently used in situations where a less general type would suffice. *) local fun leastGenStructDec(StructureDec { bindings, ... }) = (* Declarations are independent so can be processed in order. *) List.app (leastGenStructValue o #value) bindings | leastGenStructDec(CoreLang{dec, ...}) = setLeastGeneralTypes(dec, lex) | leastGenStructDec(Localdec{decs, body, ...}) = ( (* Process the body in reverse order then the declaration in reverse. *) List.foldr (fn (d, ()) => leastGenStructDec d) () body; List.foldr (fn (d, ()) => leastGenStructDec d) () decs ) and leastGenStructValue(StructureIdent _) = () | leastGenStructValue(StructDec {alist, ...}) = (* Declarations in reverse order. *) List.foldr (fn (d, ()) => leastGenStructDec d) () alist | leastGenStructValue(FunctorAppl {arg, ...}) = leastGenStructValue arg | leastGenStructValue(LetDec {decs, body, ...}) = ( (* First the body then the declarations in reverse. *) leastGenStructValue body; List.foldr (fn (d, ()) => leastGenStructDec d) () decs ) | leastGenStructValue(SigConstraint {str, ...}) = leastGenStructValue str fun leastGenTopDec(StrDec(aStruct, _)) = leastGenStructDec aStruct | leastGenTopDec(FunctorDec(fbinds, _)) = List.app(fn{body, ...} => leastGenStructValue body) fbinds | leastGenTopDec(SignatureDec _) = () in val () = (* These are independent so can be processed in order. *) List.app leastGenTopDec strs end (* Apply a function which returns a pair of codelists to a list of structs. This now threads the debugging environment through the functions so the name is no longer really appropriate. DCJM 23/2/01. *) fun mapPair (_: 'a * debuggerStatus -> {code: codeBinding list, debug: debuggerStatus}) [] debug = { code = [], debug = debug } | mapPair f (h::t) debug = let (* Process the list in order. In the case of a declaration sequence later entries in the list may refer to earlier ones. *) val this = f (h, debug); val rest = mapPair f t (#debug this); in (* Return the combined code. *) { code = #code this @ #code rest, debug = #debug rest } end; fun applyMatchActions (code : codetree, actions, sourceIds, mkAddr, level) = let (* Generate a new structure which will match the given signature. A structure is represented by a vector of entries, and its signature is a map which gives the offset in the vector of each value. When we match a signature the candidate structure will in general not have its entries in the same positions as the target. We have to construct a new structure from it with the entries in the correct positions. In most cases the optimiser will simplify this code considerably so there is no harm in using a general mechanism. Nevertheless, we check for the case when we are building a structure which is a direct copy of the original and use the original code if possible. *) fun matchSubStructure (code: codetree, actions: structureMatch): codetree * bool = let val decs = multipleUses (code, fn () => mkAddr 1, level) (* First sort by the address in the destination vector. This previously used Misc.quickSort but that results in a lot of memory allocation for the partially sorted lists. Since we should have exactly N items the range checking in "update" and the "valOf" provide additional checking that all the items are present. *) val a = Array.array(List.length actions, NONE) val () = List.app(fn (i, action) => Array.update(a, i, SOME action)) actions val sortedActions = Array.foldri (fn (n, a, l) => (n, valOf a) :: l) [] a fun applyAction ((destAddr, StructureMatch { sourceStructure, contentsMatch }), (otherCode, allSame)) = let val access = structAccess sourceStructure; (* Since these have come from a signature we might expect all the entries to be "formal". However if the structure is global the entries in the signature may be global, and if the structure is in a "struct .. end" it may be local. *) val (code, equalDest) = case access of Formal sourceAddr => (mkInd (sourceAddr, #load decs level), sourceAddr=destAddr) | _ => (codeStruct (sourceStructure, level), false) val (resCode, isSame) = matchSubStructure (code, contentsMatch: structureMatch) in (resCode::otherCode, allSame andalso equalDest andalso isSame) end | applyAction ((destAddr, ValueMatch { sourceValue as Value{typeOf=sourceTypeOf, name, ...}, coercion, targetType }), (otherCode, allSame)) = let (* Set up a new type variable environment in case this needs to create type values to match a polymorphic source value to a monomorphic context. *) val typeVarMap = TypeVarMap.defaultTypeVarMap(mkAddr, level) (* If the entry is from a signature select from the code. Apply any coercion from constructors to values. *) fun loadCode localLevel = case sourceValue of Value{access=Formal svAddr, ...} => ( case coercion of NoCoercion => mkInd (svAddr, #load decs localLevel) | ExceptionToValue => let fun loadEx l = mkInd (svAddr, #load decs l) in case getFnArgType sourceTypeOf of NONE => mkTuple [loadEx localLevel, mkStr name, CodeZero, codeLocation nullLocation] | SOME _ => let val nLevel = newLevel level in mkProc (mkTuple[loadEx nLevel, mkStr name, mkLoadArgument 0, codeLocation nullLocation], 1, "", getClosure nLevel, 0) end end | ConstructorToValue => (* Extract the injection function/nullary value. *) ValueConstructor.extractInjection(mkInd (svAddr, #load decs localLevel)) ) | _ => ( case coercion of NoCoercion => codeVal (sourceValue, localLevel, typeVarMap, [], lex, location nullLex) | ExceptionToValue => codeExFunction(sourceValue, localLevel, typeVarMap, [], lex, location nullLex) | ConstructorToValue => mkInd(1, codeVal (sourceValue, localLevel, typeVarMap, [], lex, location nullLex)) ) local val (copiedCandidate, sourceVars) = generalise sourceTypeOf val sourceVars = List.filter (fn {equality, ...} => not justForEqualityTypes orelse equality) sourceVars val () = case unifyTypes(copiedCandidate, targetType) of NONE => () | SOME report => (print(name ^ ":\n"); PolyML.print report; raise InternalError "unifyTypes failed in pass 3") val filterTypeVars = List.filter (fn tv => not justForEqualityTypes orelse tvEquality tv) val destVars = filterTypeVars (getPolyTypeVars(targetType, fn _ => NONE)) (* If we have the same polymorphic variables in the source and destination we don't need to apply a coercion. N.B. We may have the same number of polymorphic variables but still have to apply it if we have, for example, fun f x => x matching val f: 'a list -> 'a list. *) fun equalEntry({value=source, ...}, destTv) = case eventual source of TypeVar sourceTv => sameTv(sourceTv, destTv) | _ => false in val (polyCode, justCopy) = if ListPair.allEq equalEntry (sourceVars, destVars) then (loadCode(level) (* Nothing to do. *), (* We're just copying if this is the same address. *) case sourceValue of Value{access=Formal sourceAddr, ...} => destAddr=sourceAddr | _ => false) else if null destVars (* Destination is monomorphic. *) then (applyToInstance(sourceVars, level, typeVarMap, loadCode), false) else let open TypeVarMap val destPolymorphism = List.length destVars val localLevel = newLevel level val argAddrs = List.tabulate(destPolymorphism, fn n => fn l => mkLoadParam(n, l, localLevel)) val argMap = ListPair.zipEq(destVars, argAddrs) val addrs = ref 0 fun mkAddrs n = ! addrs before (addrs := !addrs+n) val newTypeVarMap = extendTypeVarMap(argMap, mkAddrs, localLevel, typeVarMap) (* Apply the source to the parameters provided by the destination. In almost all cases we will be removing polymorphism here but it is possible to add polymorphism through type definitions of the form type 'a t = int. *) val application = applyToInstance(sourceVars, localLevel, newTypeVarMap, loadCode) in (mkProc( mkEnv(getCachedTypeValues newTypeVarMap, application), destPolymorphism, name ^ "(P)", getClosure localLevel, !addrs), false) end end in (mkEnv(TypeVarMap.getCachedTypeValues typeVarMap, polyCode) :: otherCode, (* We can use the original structure if nothing else has changed, the offset in the destination structure is the same as the offset in the source and we don't have any coercion. *) allSame andalso justCopy andalso (case coercion of NoCoercion => true | _ => false)) end | applyAction ((_, TypeIdMatch { sourceIdNo, isEquality }), (otherCode, _)) = (* Get the corresponding source ID. *) (codeAccess(sourceIds(sourceIdNo, isEquality), level) :: otherCode, false) val (codeList, isAllEq) = List.foldr applyAction ([], true) sortedActions in if isAllEq then (code, true) else (mkEnv (#dec decs, mkTuple codeList), false) end in #1 (matchSubStructure (code, actions)) end (* applyMatchActions *) (* If we are declaring a structure with an opaque signature we need to create the run-time IDs for newly generated IDs. *) fun loadOpaqueIds (opaqueIds, mkAddr, level) = let fun decId { dest as TypeId{idKind=dKind, ...}, source } = let val { addr=idAddr, level=idLevel } = vaLocal(idAccess dest) val addr = mkAddr 1; val () = idAddr := addr and () = idLevel := level val isDatatype = case dKind of Bound{isDatatype, ...} => isDatatype | _ => false val idCode = codeGenerativeId{source=source, isEq=isEquality dest, isDatatype=isDatatype, mkAddr=mkAddr, level=level} in mkDec(addr, idCode) end in List.map decId opaqueIds end (* Code-generate a structure value. *) fun structureCode (str, strName, debugEnv, mkAddr, level: level): { code: codeBinding list, load: codetree } = case str of FunctorAppl {arg, valRef = ref functs, argIds=ref argIds, resIds=ref resIds, matchToArgument=ref matchToArgument, ...} => let val {code = argCodeSource, load = argLoadSource, ...} = structureCode (arg, strName, debugEnv, mkAddr, level) (* Match the actual argument to the required arguments. *) fun getMatchedId(n, isEq) = case #source(List.nth (argIds, n)) of id as TypeId{idKind=TypeFn _, ...} => (* Have to generate a function here. *) Global(codeGenerativeId{source=id, isEq=isEq, isDatatype=false(*??*), mkAddr=mkAddr, level=level}) | id => idAccess id val argCode = applyMatchActions(argLoadSource, matchToArgument, getMatchedId, mkAddr, level) (* To produce the generative type IDs we need to save the result vector returned by the functor application and then generate the new type IDs from the IDs in it. To make valid source IDs we have to turn the Formal entries in the signature into Selected entries. *) val resAddr = mkAddr 1 local val dummyResStruct = makeLocalStruct("", undefinedSignature, []) (* Dummy structure. *) val resl = vaLocal (structAccess dummyResStruct); val () = #addr resl := resAddr; val () = #level resl := level fun mkSelected { source = TypeId{idKind, access = Formal addr, description}, dest } = { source = TypeId{idKind=idKind, access = makeSelected(addr, dummyResStruct), description = description }, dest = dest } | mkSelected _ = raise InternalError "makeSelected: Not Bound or not Formal" val resultIds = List.map mkSelected resIds in val loadIds = loadOpaqueIds(resultIds, mkAddr, level) end val functorCode = case functs of SOME(Functor{access=functorAccess, ...}) => codeAccess (functorAccess, level) | NONE => raise InternalError "FunctorAppl: undefined" in (* Evaluate the functor. *) { code = argCodeSource @ (mkDec(resAddr, mkEval (functorCode, [argCode])) :: loadIds), load = mkLoadLocal resAddr } end | StructureIdent {valRef = ref v, ...} => { code = [], load = codeStruct (valOf v, level) } | LetDec {decs, body = localStr, ...} => let (* let strdec in strexp end *) (* Generate the declarations but throw away the loads. *) val typeVarMap = TypeVarMap.defaultTypeVarMap(mkAddr, level) (* TODO: Get the debug environment correct here. *) fun processBody(decs, _, debugEnv, _, _, _) = (decs, debugEnv) val (code, debug) = codeStrdecs(strName, decs, debugEnv, mkAddr, level, typeVarMap, [], processBody) val {code = bodyCode, load = bodyLoad } = structureCode (localStr, strName, debug, mkAddr, level) in { code = TypeVarMap.getCachedTypeValues typeVarMap @ code @ bodyCode, load = bodyLoad } end | StructDec {alist, matchToResult=ref matchToResult, ...} => let val typeVarMap = TypeVarMap.defaultTypeVarMap(mkAddr, level) fun processBody(decs, _, debugEnv, _, _, _) = (decs: codeBinding list, debugEnv) val (coded, _(*debugEnv*)) = codeStrdecs(strName, alist, debugEnv, mkAddr, level, typeVarMap, [], processBody) (* We match to the dummy signature here. If there is a signature outside we will match again. This results in double copying but that should all be sorted out by the optimiser. *) val loads = List.rev(List.foldl(fn (s, l) => codeLoadStrdecs(s, level) @ l) [] alist) in (* The result is a block containing the declarations and code to load the results. *) { code = TypeVarMap.getCachedTypeValues typeVarMap @ coded, load = applyMatchActions (mkTuple loads, matchToResult, fn _ => raise Subscript, mkAddr, level) } end | SigConstraint { str, opaqueIds=ref opaqueIds, matchToConstraint = ref matchToConstraint,... } => let val {code = strCode, load = strLoad, ...} = structureCode (str, strName, debugEnv, mkAddr, level) val tempDecs = multipleUses (strLoad, fn () => mkAddr 1, level); val ids = loadOpaqueIds(opaqueIds, mkAddr, level) in { code = strCode @ #dec tempDecs @ ids, load = applyMatchActions (#load tempDecs level, matchToConstraint, fn _ => raise Subscript, mkAddr, level) } end (* structureCode *) (* We need to generate code for the declaration and then code to load the results into a tuple. *) and codeStrdecs (strName, [], debugEnv, mkAddr, level, typeVarMap, leadingDecs, processBody) = processBody(leadingDecs: codeBinding list, strName, debugEnv, mkAddr, level, typeVarMap) (* Do the continuation. *) | codeStrdecs (strName, (StructureDec { bindings = structList, typeIdsForDebug = ref debugIds, ... }) :: sTail, debugEnv, mkAddr, level, _(*typeVarMap*), leadingDecs, processBody) = let fun codeStructureBind ({name, value, valRef, ...}: structBind, debug) = let val structureVal = valOf(! valRef) val sName = strName ^ name ^ "." val {code = strCode, load = strLoad, ...} = structureCode (value, sName, debug, mkAddr, level) val addr = mkAddr 1 val var = vaLocal (structAccess structureVal) val () = #addr var := addr; val () = #level var := level; val (debugDecs, newDebug) = makeStructDebugEntries([structureVal], debugEnv, level, lex, mkAddr) in (* Get the code and save the result in the variable. *) { code = strCode @ [mkDec (addr, strLoad)] @ debugDecs : codeBinding list, debug = newDebug } end val { code: codeBinding list, debug = strDebug } = (* Code-generate each declaration. *) mapPair codeStructureBind structList debugEnv val (debugIdDecs, idDebug) = makeTypeIdDebugEntries(debugIds, strDebug, level, lex, mkAddr) (* A structure binding may introduce new type IDs either directly or by way of opaque signatures or functor application. Ideally we'd add these using something like markTypeConstructors but for now just start a new environment. *) (* TODO: Check this. It looks as though TypeVarMap.getCachedTypeValues newTypeVarMap always returns the empty list. *) val newTypeVarMap = TypeVarMap.defaultTypeVarMap(mkAddr, level) val (codeRest, debugRest) = codeStrdecs (strName, sTail, idDebug, mkAddr, level, newTypeVarMap, [], processBody) in (leadingDecs @ code @ debugIdDecs @ TypeVarMap.getCachedTypeValues newTypeVarMap @ codeRest, debugRest) end | codeStrdecs (strName, (Localdec {decs, body, ...}) :: sTail, debugEnv, mkAddr, level, typeVarMap, leadingDecs, processBody) = let fun processTail(previousDecs, newStrName, newDebugEnv, newMkAddr, newLevel, newTypeVarMap) = let (* TODO: Get the debug environment right here. *) in codeStrdecs (newStrName, sTail, newDebugEnv, newMkAddr, newLevel, newTypeVarMap, previousDecs, processBody) end fun processBody(previousDecs, newStrName, newDebugEnv, newMkAddr, newLevel, newTypeVarMap) = let (* TODO: Get the debug environment right here. *) in codeStrdecs (newStrName, body, newDebugEnv, newMkAddr, newLevel, newTypeVarMap, previousDecs, processTail) end in (* Process the declarations then the body and then the tail. *) codeStrdecs (strName, decs, debugEnv, mkAddr, level, typeVarMap, leadingDecs, processBody) end | codeStrdecs (strName, (CoreLang {dec, ...}) :: sTail, debugEnv, mkAddr, level, typeVarMap, leadingDecs, processBody) = let fun processTail(newCode, newDebugEnv, newTypeVarMap) = codeStrdecs (strName, sTail, newDebugEnv, mkAddr, level, newTypeVarMap, newCode, processBody) val (code, debug) = gencode (dec, lex, debugEnv, level, mkAddr, typeVarMap, strName, processTail) in (leadingDecs @ code, debug) end (* end codeStrdecs *) (* Generate a list of load instructions to build the result tuple. *) and codeLoadStrdecs(StructureDec { bindings, ... }, _) = let fun loadStructureBind ({valRef = ref v, ...}, loads) = let val { addr=ref addr, ...} = vaLocal (structAccess(valOf v)) in mkLoadLocal addr :: loads end in (* Code-generate each declaration. *) List.foldl loadStructureBind [] bindings end | codeLoadStrdecs(Localdec {body, ...}, level) = List.foldl (fn(s, l) => codeLoadStrdecs(s, level) @ l) [] body | codeLoadStrdecs(CoreLang {vars=ref vars, ...}, level) = let (* Load each variable, exception and type ID (i.e. equality & print function) that has been declared. Since value declarations may be mutually recursive we have to code-generate the declarations first then return the values. *) val typeVarMap = TypeVarMap.defaultTypeVarMap(fn _ => raise InternalError "typeVarMap", level) fun loadVals (CoreValue v, rest) = codeVal (v, level, typeVarMap, [], nullLex, location nullLex) :: rest | loadVals (CoreStruct s, rest) = codeStruct (s, level) :: rest | loadVals (CoreType (TypeConstrSet(_, tcConstructors)), rest) = (* Type IDs are handled separately but we need to load the value constructors if this is a datatype. This is really only because of datatype replication where we need to be able to get the value constructors from the datatype. *) List.rev(List.map( fn v => codeVal (v, level, typeVarMap, [], nullLex, location nullLex)) tcConstructors) @ rest | loadVals (_, rest) = rest in List.foldl loadVals [] vars end fun codeTopdecs (StrDec(str, _), debugEnv, mkAddr) = let open TypeVarMap val level = baseLevel val typeVarMap = TypeVarMap.defaultTypeVarMap(mkAddr, level) val (code, debug) = codeStrdecs("", [str], debugEnv, mkAddr, level, typeVarMap, [], fn(decs, _, debugEnv, _, _, _) => (decs, debugEnv)) in { code = TypeVarMap.getCachedTypeValues typeVarMap @ code, debug = debug } end | codeTopdecs (FunctorDec (structList : functorBind list, _), debugEnv, mkOuterAddr) = let fun codeFunctorBind ({name, arg = {valRef=argValRef, ...}, body, valRef, resIds=ref resIds, matchToResult=ref matchToResult, debugArgVals, debugArgStructs, debugArgTypeConstrs, ...}: functorBind, debugEnv) = let val argVal = valOf(! argValRef) local (* Separate context for each functor binding. *) val address = ref 1 in fun mkAddr n = !address before (address := ! address+n) val level = newLevel baseLevel (* Inside the functor *) end val arg = vaLocal (structAccess argVal) (* Create a local binding for the argument. This allows the new variable to be a local. *) val localAddr = mkAddr 1 val () = #addr arg := localAddr val () = #level arg := level val func = valOf(!valRef) local (* These are the entries for the functor arguments. *) val (typeIdDebugDecs, typeIdDebugEnv) = makeTypeIdDebugEntries(sigBoundIds (structSignat argVal), debugEnv, level, lex, mkAddr) val (structDebugDecs, structDebugEnv) = makeStructDebugEntries(! debugArgStructs, typeIdDebugEnv, level, lex, mkAddr) val typeVarMap = TypeVarMap.defaultTypeVarMap(mkAddr, level) (* ???Check??? *) val (valDebugDecs, valDebugEnv) = makeValDebugEntries(! debugArgVals, structDebugEnv, level, lex, mkAddr, typeVarMap) val (typeDebugDecs, typeDebugEnv) = makeTypeConstrDebugEntries(! debugArgTypeConstrs, valDebugEnv, level, lex, mkAddr) in val fBindDebugDecs = typeIdDebugDecs @ structDebugDecs @ valDebugDecs @ typeDebugDecs val fBindDebugEnv = typeDebugEnv end (* Process the body and make a function out of it. *) local val {code = strCode, load = strLoad, ...} = structureCode (body, name ^ "().", fBindDebugEnv, mkAddr, level) fun getIds(n, isEq) = case #source(List.nth(resIds, n)) of id as TypeId{idKind=TypeFn _, ...} => (* Have to generate a function here. *) Global(codeGenerativeId{source=id, isEq=isEq, isDatatype=false (*??*), mkAddr=mkAddr, level=level}) | id => idAccess id val matchedCode = applyMatchActions(strLoad, matchToResult, getIds, mkAddr, level) in val functorCode = (* The function that implements the functor. *) (if getParameter inlineFunctorsTag (debugParams lex) then mkMacroProc else mkProc) (mkEnv(mkDec(localAddr, mkLoadArgument 0) :: (fBindDebugDecs @ strCode), matchedCode), 1, name, getClosure level, mkAddr 0) end (* Set the address of this variable. Because functors can only be declared at the top level the only way it can be used is if we have functor F(..) = ... functor G() = ..F.. with no semicolon between them. They will then be taken as a single declaration and F will be picked up as a local. *) val addr = mkOuterAddr 1 val Functor { access, ...} = func val var = vaLocal access val () = #addr var := addr; val () = #level var := baseLevel(* Top level *); in { code = [mkDec (addr, functorCode)], debug = debugEnv } end in mapPair codeFunctorBind structList debugEnv end | codeTopdecs(SignatureDec _, debugEnv, _) = { code = [], debug = debugEnv } and loadTopdecs (StrDec(str, ref typeIds)) = let val level = baseLevel val load = codeLoadStrdecs(str, level) (* Load all the IDs created in this topdec even if they're not directly referenced. *) fun loadIds id = codeId(id, level) in load @ List.rev(List.map loadIds typeIds) end | loadTopdecs (FunctorDec (structList, _)) = let fun loadFunctorBind ({valRef, ...}) = let val Functor{access, ...} = valOf(! valRef) val {addr = ref addr, ...} = vaLocal access in mkLoadLocal addr end in List.rev(List.map loadFunctorBind structList) end | loadTopdecs(SignatureDec _) = [] local (* Separate context for each top level item. *) val address = ref 0 in fun mkAddr n = !address before (address := ! address+n) end val coded = (* Process top level list. *) mapPair (fn (str, debug) => codeTopdecs (str, debug, mkAddr)) strs initialDebuggerStatus val loaded = List.foldl (fn (s, l) => loadTopdecs s @ l) [] strs in (* The result is code for a vector containing the results of the declarations which pass4 can use to pull out the values after the code has been run. *) (mkEnv (#code coded, mkTuple(List.rev loaded)), mkAddr 0) end (* gencodeStructs *); (* Once the code has been executed the declarations must be added to the global scope. The type and infix status environments have already been processed so they can be dumped into the global environment unchanged. The values and exceptions, however, have to be picked out the compiled code. Note: The value constructors are actually produced at the same time as their types but are dumped out by enterGlobals. *) (* This previously only processed declarations which required some code-generation and evaluation (structures, values and functors). It now includes types, signatures and fixity so that all declarations can be printed in the order of declaration. DCJM 6/6/02. *) fun pass4Structs (results, (strs: topdec list, _)) = let fun extractStruct(str, mapTypeIds, args as (addr, { fixes, values, structures, signatures, functors, types } )) = case str of StructureDec { bindings, ... } => let fun extractStructureBind ({name, valRef, line, ...}: structBind, (addr, structures)) = let val structCode = mkInd (addr, results) (* We need to replace type IDs with their Global versions. *) local val Struct{signat=Signatures { name, locations, typeIdMap, tab, ...}, ...} = valOf(!valRef) in val resultSig = makeSignature(name, tab, 0, locations, composeMaps(typeIdMap, mapTypeIds), []) end in (* Make a global structure. *) (addr + 1, (name, makeGlobalStruct (name, resultSig, structCode, [DeclaredAt line])) :: structures) end val (newAddr, newstructures) = List.foldl extractStructureBind (addr, structures) bindings in (newAddr, { structures=newstructures, functors=functors, signatures=signatures, fixes=fixes, values=values, types=types }) end | Localdec {body, ...} => List.foldl (fn(s, a) => extractStruct(s, mapTypeIds, a))args body (* Value, exception or type declaration at the top level. *) | CoreLang {vars=ref vars, ...} => let (* Enter the values and exceptions. *) (* Copy the types to replace the type IDs with the versions with Global access. *) fun replaceTypes t = let fun copyId(TypeId{idKind=Bound{ offset, ...}, ...}) = SOME(mapTypeIds offset) | copyId _ = NONE fun replaceTypeConstrs tcon = copyTypeConstr (tcon, copyId, fn x => x, fn s => s) in copyType(t, fn tv=>tv, replaceTypeConstrs) end fun makeDecs (CoreValue(Value{class, name, typeOf, locations, access, ...}), (addr, { fixes, values, structures, signatures, functors, types } )) = let (* Extract the value from the result vector except if we have a type-dependent function e.g. PolyML.print where we must use the type-dependent version. *) val newAccess = case access of Overloaded _ => access | _ => Global(mkInd (addr, results)) (* Replace the typeIDs. *) val newVal = Value{class=class, name=name, typeOf=replaceTypes typeOf, access=newAccess, locations=locations, references = NONE, instanceTypes=NONE} in (addr+1, { fixes=fixes, values=(name, newVal) :: values, structures=structures, signatures=signatures, functors=functors, types=types } ) end | makeDecs (CoreStruct dec, (addr, {fixes, values, structures, signatures, functors, types})) = (* If we open a structure we've created in the same "program" we may have a non-global substructure. We have to process any structures and also map any type IDs. *) let local val Signatures { name, locations, typeIdMap, tab, ...} = structSignat dec in val resultSig = makeSignature(name, tab, 0, locations, composeMaps(typeIdMap, mapTypeIds), []) end val strName = structName dec val newStruct = Struct { name = strName, signat = resultSig, access = Global(mkInd (addr, results)), locations = structLocations dec } in (addr+1, { fixes=fixes, values=values, structures=(strName, newStruct) :: structures, signatures=signatures, functors=functors, types=types } ) end | makeDecs (CoreFix pair, (addr, {fixes, values, structures, signatures, functors, types})) = (addr, { fixes=pair :: fixes, values=values, structures=structures, signatures=signatures, functors=functors, types=types } ) | makeDecs (CoreType (TypeConstrSet(tc, constrs)), (addr, {fixes, values, structures, signatures, functors, types})) = let fun loadConstr(Value{class, name, typeOf, locations, ...}, (addr, others)) = let val newAccess = Global(mkInd (addr, results)) (* Don't bother replacing the type ID here. fullCopyDatatype will do it. *) val newConstr = Value{class=class, name=name, typeOf=typeOf, access=newAccess, locations=locations, references = NONE, instanceTypes=NONE} in (addr+1, others @ [newConstr]) end val (nextAddr, newConstrs) = List.foldl loadConstr (addr, []) constrs val copiedTC = fullCopyDatatype(TypeConstrSet(tc, newConstrs), mapTypeIds, "") val newName = #second(splitString(tcName tc)) in (nextAddr, { fixes=fixes, values=values, structures=structures, signatures=signatures, functors=functors, types=(newName, copiedTC) :: types } ) end in List.foldl makeDecs args vars end fun extractTopDec(str, (addr, env as { fixes, values, structures, signatures, functors, types }, nIds, mapPrevTypIds)) = case str of StrDec(str, ref typeIds) => let (* Create new Free IDs for top-level IDs. *) fun loadId(TypeId{idKind=Bound{eqType, arity, ...}, description, ...}, (n, ids)) = let val newId = makeFreeId(arity, Global(mkInd(n, results)), pling eqType, description) in (n+1, newId :: ids) end | loadId _ = raise InternalError "Not Bound" (* Construct the IDs and reverse the list so the first ID is first*) val (newAddr, mappedIds) = List.foldl loadId (addr, []) typeIds val idMap = Vector.fromList mappedIds fun mapTypeIds n = if n < nIds then mapPrevTypIds n else Vector.sub(idMap, n-nIds) val (resAddr, resEnv) = extractStruct (str, mapTypeIds, (newAddr, env)) in (resAddr, resEnv, nIds + Vector.length idMap, mapTypeIds) end | FunctorDec (structList : functorBind list, _) => let (* Get the functor values. *) fun extractFunctorBind ({name, valRef, ...}: functorBind, (addr, funcs)) = let val code = mkInd (addr, results) val func = valOf(!valRef) (* We need to convert any references to typeIDs created in strdecs in the same "program". *) (* The result signature shares with the argument so we only copy IDs less than the min for the argument signature. *) val Functor {result=fnResult, name=functorName, locations=functorLocations, arg=fnArg as Struct{name = fnArgName, signat=fnArgSig, ...}, ...} = func local val Signatures { name, tab, typeIdMap, boundIds, firstBoundIndex, locations, ... } = fnArgSig fun newMap n = if n < firstBoundIndex then mapPrevTypIds n else List.nth(boundIds, n-firstBoundIndex) in val functorArgSig = makeSignature(name, tab, firstBoundIndex, locations, composeMaps(typeIdMap, newMap), boundIds) val copiedArg = Struct{name=fnArgName, signat=functorArgSig, access=structAccess fnArg, locations=structLocations fnArg} end local val Signatures { name, tab, typeIdMap, boundIds, firstBoundIndex, locations, ... } = fnResult val Signatures { boundIds=argBoundIds, firstBoundIndex=argMinTypes, ...} = functorArgSig fun newMap n = if n >= firstBoundIndex then List.nth(boundIds, n-firstBoundIndex) else if n >= argMinTypes then case List.nth(argBoundIds, n-argMinTypes) of (* Add the argument structure name onto the name of type IDs in the argument. *) TypeId{ access, idKind, description={location, name, description}} => TypeId { access=access, idKind=idKind, description= { location=location, description=description, name=if fnArgName = "" then name else fnArgName^"."^name } } else mapPrevTypIds n in val functorSigResult = makeSignature(name, tab, firstBoundIndex, locations, composeMaps(typeIdMap, newMap), boundIds) end val funcTree = makeFunctor(functorName, copiedArg, functorSigResult, makeGlobal code, functorLocations) in (addr + 1, (name, funcTree) :: funcs) end val (newAddr, newfunctors ) = List.foldl extractFunctorBind (addr, functors) structList in (newAddr, { functors=newfunctors, fixes=fixes, values=values, signatures=signatures, structures=structures, types=types }, nIds, mapPrevTypIds) end | SignatureDec (structList : sigBind list, _) => let (* We need to convert any references to typeIDs created in strdecs in the same "program". *) fun copySignature fnSig = let val Signatures { name, tab, typeIdMap, firstBoundIndex, boundIds, locations, ... } = fnSig fun mapIDs n = if n < firstBoundIndex then mapPrevTypIds n else List.nth(boundIds, n-firstBoundIndex) in makeSignature(name, tab, firstBoundIndex, locations, composeMaps(typeIdMap, mapIDs), boundIds) end val newSigs = List.map (fn ({sigRef=ref s, name, ...}: sigBind) => (name, copySignature s)) structList in (addr, { fixes=fixes, values=values, structures=structures, signatures=newSigs @ signatures, functors=functors, types=types }, nIds, mapPrevTypIds) end val empty = { fixes=[], values=[], structures=[], functors=[], types=[], signatures=[] } val (_, result, _, _) = List.foldl extractTopDec (0, empty, 0, fn _ => raise Subscript) strs; (* The entries in "result" are in reverse order of declaration and may contain duplicates. We need to reverse and filter the lists so that we end up with the lists in order and with duplicates removed. *) fun revFilter result [] = result | revFilter result ((nameValue as (name, _)) ::rest) = let (* Remove any entries further down the list if they have the same name. *) val filtered = List.filter (fn (n,_) => name <> n) rest in revFilter (nameValue :: result) filtered end in { fixes=revFilter [] (#fixes result), values=revFilter [] (#values result), structures=revFilter [] (#structures result), functors=revFilter [] (#functors result), types=revFilter [] (#types result), signatures=revFilter [] (#signatures result) } end (* pass4Structs *) structure Sharing = struct type structDec = structDec type structValue = structValue type structVals = structVals type types = types type parsetree = parsetree type lexan = lexan type pretty = pretty type values = values type typeConstrSet = typeConstrSet type codetree = codetree type signatures = signatures type functors = functors type env = env type sigBind = sigBind and functorBind = functorBind and structBind = structBind type machineWord = machineWord type fixStatus = fixStatus type topdec = topdec type program = program type typeParsetree = typeParsetree type formalArgStruct= formalArgStruct type ptProperties = ptProperties type structSigBind = structSigBind type typeVarForm = typeVarForm type sigs = sigs end end; diff --git a/mlsource/MLCompiler/TYPEIDCODE.sml b/mlsource/MLCompiler/TYPEIDCODE.sml index c8f51ed2..dc2b07d4 100644 --- a/mlsource/MLCompiler/TYPEIDCODE.sml +++ b/mlsource/MLCompiler/TYPEIDCODE.sml @@ -1,1375 +1,1375 @@ (* Copyright (c) 2009, 2013, 2015-16, 2020 David C. J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) functor TYPEIDCODE ( structure LEX : LEXSIG; structure CODETREE : CODETREESIG structure TYPETREE : TYPETREESIG structure STRUCTVALS : STRUCTVALSIG - structure DEBUG: DEBUGSIG + structure DEBUG: DEBUG structure PRETTY : PRETTYSIG structure ADDRESS : AddressSig sharing LEX.Sharing = STRUCTVALS.Sharing = PRETTY.Sharing = CODETREE.Sharing = TYPETREE.Sharing = ADDRESS ) : TYPEIDCODESIG = struct open CODETREE PRETTY ADDRESS STRUCTVALS TYPETREE (* This module deals with handling the run-time values that carry type information. At the moment that's just the equality and print operations but that will be extended. There are different versions according to whether this is a monomorphic constructor, a polymorphic constructor or a type. Monomorphic and polymorphic constructor values are passed around in the module system as run-time values for types and datatypes whereas type values are passed in the core language as an extra argument to polymorphic functions. Both monomorphic and polymorphic constructors contain a reference for the "printer" entry so that a pretty printer can be installed. The functions in polymorphic datatypes have to be applied to type values for the base types to construct a type value. Monomorphic datatypes just need some transformation. The effective types in each case are PolyType : (T('a) -> <'a t, 'a t> -> bool) * (T('a) -> 'a t * int -> pretty) ref MonoType : ( -> bool) * (t * int -> pretty) ref Type: ( -> bool) * (t * int -> pretty) where < > denotes multiple (poly-style) arguments rather than tuples. *) (* If this is true we are just using additional arguments for equality type variables. If false we are using them for all type variables and every polymorphic function is wrapped in a function that passes the type information. *) val justForEqualityTypes = true val arg1 = mkLoadArgument 0 (* Used frequently. *) val arg2 = mkLoadArgument 1 val InternalError = Misc.InternalError val orb = Word8.orb infix 7 orb; val mutableFlags = F_words orb F_mutable (* codeAccess is copied from ValueOps. *) fun codeAccess (Global code, _) = code | codeAccess (Local{addr=ref locAddr, level=ref locLevel}, level) = mkLoad (locAddr, level, locLevel) | codeAccess (Selected{addr, base}, level) = mkInd (addr, codeAccess (base, level)) | codeAccess _ = raise InternalError "No access" (* Load an identifier. *) fun codeId(TypeId{access, ...}, level) = codeAccess(access, level) (* Pretty printer code. These produce code to apply the pretty printer functions. *) fun codePrettyString(s: string) = mkDatatype[mkConst(toMachineWord tagPrettyString), mkConst(toMachineWord s)] and codePrettyBreak(n, m) = mkDatatype[mkConst(toMachineWord tagPrettyBreak), mkConst(toMachineWord n), mkConst(toMachineWord m)] and codePrettyBlock(n: int, t: bool, c: context list, args: codetree) = mkDatatype[mkConst(toMachineWord tagPrettyBlock), mkConst(toMachineWord n), mkConst(toMachineWord t), mkConst(toMachineWord c), args] (* Turn a list of codetrees into a run-time list. *) and codeList(c: codetree list, tail: codetree): codetree = List.foldr (fn (hd, tl) => mkTuple[hd, tl]) tail c (* Generate code to check that the depth is not less than the allowedDepth and if it is to print "..." rather than the given code. *) and checkDepth(depthCode: codetree, allowedDepth: int, codeOk, codeFail) = mkIf(mkBinary(BuiltIns.WordComparison{test=BuiltIns.TestLess, isSigned=true}, depthCode, mkConst(toMachineWord allowedDepth)), codeFail, codeOk) (* Subtract one from the current depth to produce the depth for sub-elements. *) and decDepth depthCode = mkBinary(BuiltIns.FixedPrecisionArith BuiltIns.ArithSub, depthCode, mkConst(toMachineWord 1)) val codePrintDefault = mkProc(codePrettyString "?", 1, "print-default", [], 0) structure TypeVarMap = struct (* Entries are either type var maps or "stoppers". *) datatype typeVarMapEntry = TypeVarFormEntry of (typeVarForm * (level->codetree)) list | TypeConstrListEntry of typeConstrs list type typeVarMap = { entryType: typeVarMapEntry, (* Either the type var map or a "stopper". *) cache: (* Cache of new type values. *) {typeOf: types, address: int, decCode: codeBinding} list ref, mkAddr: int->int, (* Make new addresses at this level. *) level: level (* Function nesting level. *) } list (* Default map. *) fun defaultTypeVarMap (mkAddr, level) = [{entryType=TypeConstrListEntry[], cache=ref [], mkAddr=mkAddr, level=level}] fun markTypeConstructors(typConstrs, mkAddr, level, tvs) = {entryType = TypeConstrListEntry typConstrs, cache = ref [], mkAddr=mkAddr, level=level} :: tvs fun getCachedTypeValues(({cache=ref cached, ...}) ::_): codeBinding list = (* Extract the values from the list. The later values may refer to earlier so the list must be reversed. *) List.rev (List.map (fn{decCode, ...} => decCode) cached) | getCachedTypeValues _ = raise Misc.InternalError "getCachedTypeValues" (* Extend a type variable environment with a new map of type variables to load functions. *) fun extendTypeVarMap (tvMap: (typeVarForm * (level->codetree)) list, mkAddr, level, typeVarMap) = {entryType = TypeVarFormEntry tvMap, cache = ref [], mkAddr=mkAddr, level=level} :: typeVarMap (* If we find the type var in the map return it as a type. This is used to eliminate apparently generalisable type vars from the list. *) fun mapTypeVars [] _ = NONE | mapTypeVars ({entryType=TypeVarFormEntry typeVarMap, ...} :: rest) tyVar = ( case List.find(fn(t, _) => sameTv(t, tyVar)) typeVarMap of SOME (tv, _) => SOME(TypeVar tv) | NONE => mapTypeVars rest tyVar ) | mapTypeVars (_ :: rest) tyVar = mapTypeVars rest tyVar (* Check to see if a type constructor is in the "stopper" set and return the level if it is. *) fun checkTypeConstructor(_, []) = ~1 (* Not there. *) | checkTypeConstructor(tyCons, {entryType=TypeVarFormEntry _, ...} :: rest) = checkTypeConstructor(tyCons, rest: typeVarMap) | checkTypeConstructor(tyCons, {entryType=TypeConstrListEntry tConstrs, ...} :: rest) = if List.exists(fn t => sameTypeId(tcIdentifier t, tcIdentifier tyCons)) tConstrs then List.length rest + 1 else checkTypeConstructor(tyCons, rest) local open TypeValue (* The printer and equality functions must be valid functions even when they will never be called. We may have to construct dummy type values by applying a polymorphic type constructor to them and if they don't have the right form the optimiser will complain. If we're only using type values for equality type variables the default print function will be used in polymorphic functions so must print "?". *) val errorFunction2 = mkProc(CodeZero, 2, "errorCode2", [], 0) val codeFn = mkProc(codePrettyString "fn", 1, "print-function", [], 0) local fun typeValForMonotype typConstr = let val codedId = codeId(tcIdentifier typConstr, baseLevel) val printerRefAddress = extractPrinter codedId val printFn = (* Create a function to load the printer ref and apply to the args. *) mkProc( mkEval( mkLoadOperation(LoadStoreMLWord{isImmutable=false}, printerRefAddress, CodeZero), [arg1]), 1, "print-" ^ tcName typConstr, [], 0) in createTypeValue{ eqCode=extractEquality codedId, printCode=printFn, boxedCode=extractBoxed codedId, sizeCode=extractSize codedId} end in (* A few common types. These are effectively always cached. *) val fixedIntCode = typeValForMonotype fixedIntConstr and intInfCode = typeValForMonotype intInfConstr and boolCode = typeValForMonotype boolConstr and stringCode = typeValForMonotype stringConstr and charCode = typeValForMonotype charConstr end (* Code generate this now so we only get one entry. *) val codeTuple = mkTuple[ createTypeValue{ (* Unused type variable. *) eqCode=errorFunction2, printCode=codePrintDefault, boxedCode=boxedEither, sizeCode=singleWord}, createTypeValue{ (* Function. *) eqCode=errorFunction2, printCode=codeFn, boxedCode=boxedAlways, sizeCode=singleWord}, fixedIntCode, intInfCode, boolCode, stringCode, charCode ] val code = genCode(codeTuple, [], 0)() in (* Default code used for a type variable that is not referenced but needs to be provided to satisfy the type. *) val defaultTypeCode = mkInd(0, code) val functionCode = mkInd(1, code) val cachedCode = [(fixedIntConstr, mkInd(2, code)), (intInfConstr, mkInd(3, code)), (boolConstr, mkInd(4, code)), (stringConstr, mkInd(5, code)), (charConstr, mkInd(6, code))] end fun findCachedTypeCode(typeVarMap: typeVarMap, typ): ((level->codetree) * int) option = let (* Test if we have the same type as the cached type. *) fun sameType (t1, t2) = case (eventual t1, eventual t2) of (TypeVar tv1, TypeVar tv2) => ( case (tvValue tv1, tvValue tv2) of (EmptyType, EmptyType) => sameTv(tv1, tv2) | _ => false ) | (FunctionType{arg=arg1, result=result1}, FunctionType{arg=arg2, result=result2}) => sameType(arg1, arg2) andalso sameType(result1, result2) | (LabelledType{recList=list1, ...}, LabelledType{recList=list2, ...}) => ListPair.allEq( fn({name=n1, typeof=t1}, {name=n2, typeof=t2}) => n1 = n2 andalso sameType(t1, t2)) (list1, list2) | (TypeConstruction{constr=c1, args=a1, ...}, TypeConstruction{constr=c2, args=a2, ...}) => sameTypeConstr(c1, c2) andalso ListPair.allEq sameType (a1, a2) | _ => false and sameTypeConstr(tc1, tc2) = sameTypeId(tcIdentifier tc1, tcIdentifier tc2) fun findCodeFromCache([], _) = NONE | findCodeFromCache(({cache=ref cache, level, ...} :: rest): typeVarMap, ty) = ( case List.find(fn {typeOf, ...} => sameType(typeOf, ty)) cache of NONE => findCodeFromCache(rest, ty) | SOME{address, ...} => SOME(fn l => mkLoad(address, l, level), List.length rest +1) ) in case typ of TypeVar tyVar => ( case tvValue tyVar of EmptyType => let (* If it's a type var it is either in the type var list or we return the default. It isn't in the cache. *) fun findCodeFromTypeVar([], _) = ((fn _ => defaultTypeCode), 0) (* Return default code for a missing type variable. This can occur if we have unreferenced type variables that need to be supplied but are treated as "don't care". *) | findCodeFromTypeVar({entryType=TypeVarFormEntry typeVarMap, ...} :: rest, tyVar) = ( case List.find(fn(t, _) => sameTv(t, tyVar)) typeVarMap of SOME(_, codeFn) => (codeFn, List.length rest+1) | NONE => findCodeFromTypeVar(rest, tyVar) ) | findCodeFromTypeVar(_ :: rest, tyVar) = findCodeFromTypeVar(rest, tyVar) in SOME(findCodeFromTypeVar(typeVarMap, tyVar)) end | OverloadSet _ => let val constr = typeConstrFromOverload(typ, false) in findCachedTypeCode(typeVarMap, mkTypeConstruction(tcName constr, constr, [], [])) end | ty => findCachedTypeCode(typeVarMap, ty) ) | TypeConstruction { constr, args, ...} => let fun sameTypeConstr(tc1, tc2) = sameTypeId(tcIdentifier tc1, tcIdentifier tc2) in if tcIsAbbreviation constr (* Type abbreviation *) then findCachedTypeCode(typeVarMap, makeEquivalent (constr, args)) else if null args then (* Check the permanently cached monotypes. *) case List.find(fn (t, _) => sameTypeConstr(t, constr)) cachedCode of SOME (_, c) => SOME ((fn _ => c), ~1) | NONE => findCodeFromCache(typeVarMap, typ) else findCodeFromCache(typeVarMap, typ) end | FunctionType _ => SOME(fn _ => functionCode, ~1) (* Every function has the same code. *) | _ => findCodeFromCache(typeVarMap, typ) end end open TypeVarMap (* Find the earliest entry in the cache table where we can put this entry. *) fun getMaxDepth (typeVarMap: typeVarMap) (ty: types, maxSoFar:int) : int = case findCachedTypeCode(typeVarMap, ty) of SOME (_, cacheDepth) => Int.max(cacheDepth, maxSoFar) | NONE => let in case ty of TypeVar tyVar => ( case tvValue tyVar of OverloadSet _ => maxSoFar (* Overloads are all global. *) | EmptyType => maxSoFar | tyVal => getMaxDepth typeVarMap (tyVal, maxSoFar) ) | TypeConstruction{constr, args, ...} => if tcIsAbbreviation constr (* May be an alias *) then getMaxDepth typeVarMap (makeEquivalent (constr, args), maxSoFar) else List.foldl (getMaxDepth typeVarMap) (Int.max(maxSoFar, checkTypeConstructor(constr, typeVarMap))) args | LabelledType {recList, ...} => List.foldl (fn ({typeof, ...}, m) => getMaxDepth typeVarMap (typeof, m)) maxSoFar recList | _ => maxSoFar end (* Get the boxedness status for a type i.e. whether values of the type are always addresses, always tagged integers or could be either. *) fun boxednessForType(ty, level: level, getTypeValueForID, typeVarMap): codetree = case findCachedTypeCode(typeVarMap, ty) of SOME (code, _) => TypeValue.extractBoxed(code level) | NONE => let fun boxednessForConstruction(constr, args): codetree = (* Get the boxedness for a datatype construction. *) let (* Get the boxedness functions for the argument types. This applies only to polytypes. *) fun getArg ty : codetree = let val boxedFun = boxednessForType(ty, level, getTypeValueForID, typeVarMap) open TypeValue in (* We need a type value here although only the boxedFun will be used. *) createTypeValue{eqCode=CodeZero, printCode=CodeZero, boxedCode=boxedFun, sizeCode=singleWord} end val codeForId = TypeValue.extractBoxed(getTypeValueForID(tcIdentifier constr, args, level)) in (* Apply the function we obtained to any type arguments. *) if null args then codeForId else mkEval(codeForId, map getArg args) end in case ty of TypeVar tyVar => ( case tvValue tyVar of OverloadSet _ => boxednessForConstruction(typeConstrFromOverload(ty, false), []) | EmptyType => raise InternalError "boxedness: should already have been handled" | tyVal => boxednessForType(tyVal, level, getTypeValueForID, typeVarMap) ) | TypeConstruction{constr, args, ...} => if tcIsAbbreviation constr (* May be an alias *) then boxednessForType (makeEquivalent (constr, args), level, getTypeValueForID, typeVarMap) else boxednessForConstruction(constr, args) | LabelledType {recList=[{typeof=singleton, ...}], ...} => (* Unary tuples are optimised - no indirection. *) boxednessForType(singleton, level, getTypeValueForID, typeVarMap) | LabelledType _ => TypeValue.boxedAlways (* Tuple are currently always boxed. *) (* Functions are handled in the cache case. *) | _ => raise InternalError "boxednessForType: Unknown type" end (* Get the size for values of the type. A value N other than 1 means that every value of the type is a pointer to a tuple of exactly N words. Zero is never used. *) fun sizeForType(ty, level, getTypeValueForID, typeVarMap): codetree = case findCachedTypeCode(typeVarMap, ty) of SOME (code, _) => TypeValue.extractSize(code level) | NONE => let fun sizeForConstruction(constr, args): codetree = (* Get the size for a datatype construction. *) let (* Get the size functions for the argument types. This applies only to polytypes. *) fun getArg ty : codetree = let val sizeFun = sizeForType(ty, level, getTypeValueForID, typeVarMap) open TypeValue in (* We need a type value here although only the sizeFun will be used. *) createTypeValue{eqCode=CodeZero, printCode=CodeZero, boxedCode=CodeZero, sizeCode=sizeFun} end val codeForId = TypeValue.extractSize(getTypeValueForID(tcIdentifier constr, args, level)) in (* Apply the function we obtained to any type arguments. *) if null args then codeForId else mkEval(codeForId, map getArg args) end in case ty of TypeVar tyVar => ( case tvValue tyVar of OverloadSet _ => sizeForConstruction(typeConstrFromOverload(ty, false), []) | EmptyType => raise InternalError "size: should already have been handled" | tyVal => sizeForType(tyVal, level, getTypeValueForID, typeVarMap) ) | TypeConstruction{constr, args, ...} => if tcIsAbbreviation constr (* May be an alias *) then sizeForType (makeEquivalent (constr, args), level, getTypeValueForID, typeVarMap) else sizeForConstruction(constr, args) | LabelledType {recList=[{typeof=singleton, ...}], ...} => (* Unary tuples are optimised - no indirection. *) sizeForType(singleton, level, getTypeValueForID, typeVarMap) | LabelledType{recList, ...} => let val length = List.length recList in (* Set the length to the number of words that can be unpacked. If there are more than 4 items it's probably not worth packing them into other tuples so set this to one. *) if length <= 4 (*!maxPacking*) then mkConst(toMachineWord length) else TypeValue.singleWord end (* Functions are handled in the cache case. *) | _ => raise InternalError "sizeForType: Unknown type" end fun printerForType(ty, baseLevel, argTypes: typeVarMap) = let fun printCode(typ, level: level) = ( case typ of typ as TypeVar tyVar => ( case tvValue tyVar of EmptyType => ( case findCachedTypeCode(argTypes, typ) of SOME (code, _) => TypeValue.extractPrinter(code level) | NONE => raise InternalError "printerForType: should already have been handled" ) | OverloadSet _ => let val constr = typeConstrFromOverload(typ, false) in printCode(mkTypeConstruction(tcName constr, constr, [], []), level) end | _ => (* Just a bound type variable. *) printCode(tvValue tyVar, level) ) | TypeConstruction { constr=typConstr, args, name, ...} => if tcIsAbbreviation typConstr (* Handle type abbreviations directly *) then printCode(makeEquivalent (typConstr, args), level) else let val nLevel = newLevel level (* Get the type Id and put in code to extract the printer ref. *) val codedId = codeId(tcIdentifier typConstr, nLevel) open TypeValue val printerRefAddress = extractPrinter codedId (* We need a type value here. The printer field will be used to print the type argument and the boxedness and size fields may be needed to extract the argument from the constructed value. *) fun makePrinterId t = let fun codeForId(typeId, _, l) = codeId(typeId, l) in createTypeValue {eqCode=CodeZero, printCode=printCode(t, nLevel), boxedCode=boxednessForType(t, nLevel, codeForId, argTypes), sizeCode=sizeForType(t, nLevel, codeForId, argTypes)} end val argList = map makePrinterId args in case args of [] => (* Create a function that, when called, will extract the function from the reference and apply it the pair of the value and the depth. *) mkProc( mkEval( mkLoadOperation(LoadStoreMLWord{isImmutable=false}, printerRefAddress, CodeZero), [arg1]), 1, "print-"^name, getClosure nLevel, 0) | _ => (* Construct a function, that when called, will extract the function from the reference and apply it first to the base printer functions and then to the pair of the value and depth. *) mkProc( mkEval( mkEval( mkLoadOperation(LoadStoreMLWord{isImmutable=false}, printerRefAddress, CodeZero), argList), [arg1]), 1, "print-"^name, getClosure nLevel, 0) end | LabelledType { recList=[], ...} => (* Empty tuple: This is the unit value. *) mkProc(codePrettyString "()", 1, "print-labelled", [], 0) | LabelledType {recList=[{name, typeof}], ...} => let (* Optimised unary record *) val localLevel = newLevel level val entryCode = mkEval(printCode(typeof, localLevel), [arg1]) val printItem = codeList([codePrettyString(name^" ="), codePrettyBreak(1, 0), entryCode, codePrettyString "}"], CodeZero) in mkProc( codePrettyBlock(1, false, [], mkTuple[codePrettyString "{", printItem]), 1, "print-labelled", getClosure localLevel, 0) end | LabelledType (r as { recList, ...}) => let (* See if this has fields numbered 1=, 2= etc. N.B. If it has only one field we need to print 1= since we don't have singleton tuples. *) fun isRec([], _) = true | isRec({name, ...} :: l, n) = name = Int.toString n andalso isRec(l, n+1) val isTuple = recordIsFrozen r andalso isRec(recList, 1) andalso List.length recList >= 2 val localLevel = newLevel level val valToPrint = mkInd(0, arg1) and depthCode = mkInd(1, arg1) val fields = List.tabulate(List.length recList, fn n => n) val items = ListPair.zipEq(recList, fields) (* The ordering on fields is designed to allow mixing of tuples and records (e.g. #1). It puts shorter names before longer so that #11 comes after #2 and before #100. For named records it does not make for easy reading so we sort those alphabetically when printing. *) val printItems = if isTuple then items else Misc.quickSort(fn ({name = a, ...}, _) => fn ({name = b, ...}, _) => a <= b) items fun asRecord([], _) = raise Empty (* Shouldn't happen. *) | asRecord([({name, typeof, ...}, offset)], _) = let val entryCode = (* Last field: no separator. *) mkEval(printCode(typeof, localLevel), [mkTuple[mkInd(offset, valToPrint), decDepth depthCode]]) val (start, terminator) = if isTuple then ([], ")") else ([codePrettyString(name^" ="), codePrettyBreak(1, 0)], "}") in codeList(start @ [entryCode, codePrettyString terminator], CodeZero) end | asRecord(({name, typeof, ...}, offset) :: fields, depth) = let val (start, terminator) = if isTuple then ([], ")") else ([codePrettyString(name^" ="), codePrettyBreak(1, 0)], "}") in checkDepth(depthCode, depth, codeList( start @ [ mkEval( printCode(typeof, localLevel), [mkTuple[mkInd(offset, valToPrint), decDepth depthCode]]), codePrettyString ",", codePrettyBreak (1, 0) ], asRecord(fields, depth+1)), codeList([codePrettyString ("..." ^ terminator)], CodeZero) ) end in mkProc( codePrettyBlock(1, false, [], mkTuple[codePrettyString (if isTuple then "(" else "{"), asRecord(printItems, 0)]), 1, "print-labelled", getClosure localLevel, 0) end | FunctionType _ => mkProc(codePrettyString "fn", 1, "print-function", [], 0) | _ => mkProc(codePrettyString "", 1, "print-empty", [], 0) ) in printCode(ty, baseLevel) end and makeEq(ty, level: level, getTypeValueForID, typeVarMap): codetree = let fun equalityForConstruction(constr, args): codetree = (* Generate an equality function for a datatype construction. *) let (* Get argument types parameters for polytypes. There's a special case here for type vars, essentially the type arguments to the datatype, to avoid taking apart the type value record and then building it again. *) fun getArg ty = if (case ty of TypeVar tyVar => (case tvValue tyVar of EmptyType => true | _ => false) | _ => false) then ( case findCachedTypeCode(typeVarMap, ty) of SOME (code, _) => code level | NONE => raise InternalError "getArg" ) else let val eqFun = makeEq(ty, level, getTypeValueForID, typeVarMap) open TypeValue in (* We need a type value here. The equality function will be used to compare the argument type and the boxedness and size parameters may be needed for the constructors. *) createTypeValue{eqCode=eqFun, printCode=CodeZero, boxedCode=boxednessForType(ty, level, getTypeValueForID, typeVarMap), sizeCode=sizeForType(ty, level, getTypeValueForID, typeVarMap)} end val resFun = let val iden = tcIdentifier constr in (* Special case: If this is ref, Array.array or Array2.array we must use pointer equality and not attempt to create equality functions for the argument. It may not be an equality type. *) if isPointerEqType iden then equalPointerOrWordFn else let open TypeValue val codeForId = extractEquality(getTypeValueForID(tcIdentifier constr, args, level)) in (* Apply the function we obtained to any type arguments. *) if null args then codeForId else mkEval(codeForId, map getArg args) end end in resFun end in case ty of TypeVar tyVar => ( case tvValue tyVar of OverloadSet _ => (* This seems to occur if there are what amount to indirect references to literals. *) equalityForConstruction(typeConstrFromOverload(ty, false), []) | EmptyType => ( case findCachedTypeCode(typeVarMap, ty) of SOME (code, _) => TypeValue.extractEquality(code level) | NONE => raise InternalError "makeEq: should already have been handled" ) | tyVal => makeEq(tyVal, level, getTypeValueForID, typeVarMap) ) | TypeConstruction{constr, args, ...} => if tcIsAbbreviation constr (* May be an alias *) then makeEq (makeEquivalent (constr, args), level, getTypeValueForID, typeVarMap) else equalityForConstruction(constr, args) | LabelledType {recList=[{typeof=singleton, ...}], ...} => (* Unary tuples are optimised - no indirection. *) makeEq(singleton, level, getTypeValueForID, typeVarMap) | LabelledType {recList, ...} => (* Combine the entries. fun eq(a,b) = #1 a = #1 b andalso #2 a = #2 b ... *) let (* Have to turn this into a new function. *) val nLevel = newLevel level fun combineEntries ([], _) = CodeTrue | combineEntries ({typeof, ...} :: t, n) = let val compareElements = makeEq(typeof, nLevel, getTypeValueForID, typeVarMap) in mkCand( mkEval(compareElements, [mkInd(n, arg1), mkInd(n, arg2)]), combineEntries (t, n+1)) end val tupleCode = combineEntries(recList, 0) in mkProc(tupleCode, 2, "eq{...}(2)", getClosure nLevel, 0) end | _ => raise InternalError "Equality for function" end (* Create equality functions for a set of possibly mutually recursive datatypes. *) fun equalityForDatatypes(typeDataList, eqAddresses, baseEqLevel, typeVarMap): (int * codetree) list = let val typesAndAddresses = ListPair.zipEq(typeDataList, eqAddresses) fun equalityForDatatype(({typeConstr=TypeConstrSet(tyConstr, vConstrs), eqStatus, (*boxedCode, sizeCode,*) ...}, addr), otherFns) = if eqStatus then let val nTypeVars = tcArity tyConstr val argTypes = List.tabulate(tcArity tyConstr, fn _ => makeTv{value=EmptyType, level=generalisable, nonunifiable=false, equality=false, printable=false}) val baseEqLevelP1 = newLevel baseEqLevel (* Argument type variables. *) val (localArgList, argTypeMap) = case argTypes of [] => ([], typeVarMap) | _ => let (* Add the polymorphic variables after the ordinary ones. *) (* Create functions to load these if they are used in the map. They may be non-local!!! *) val args = List.tabulate(nTypeVars, fn addr => fn l => mkLoadParam(addr+2, l, baseEqLevelP1)) (* Put the outer args in the map *) val varToArgMap = ListPair.zipEq(argTypes, args) (* Load the local args to return. *) val localArgList = List.tabulate (nTypeVars, fn addr => mkLoadParam(addr+2, baseEqLevelP1, baseEqLevelP1)) val addrs = ref 0 (* Make local declarations for any type values. *) fun mkAddr n = !addrs before (addrs := !addrs + n) in (localArgList, extendTypeVarMap(varToArgMap, mkAddr, baseEqLevelP1, typeVarMap)) end (* If this is a reference to a datatype we're currently generating load that address otherwise fall back to the default. *) fun getEqFnForID(typeId, _, l) = (* if sameTypeId(typeId, tcIdentifier tyConstr) andalso null argTypes then (* Directly recursive. *) TypeValue.createTypeValue{eqCode=mkLoadRecursive(l-baseLevel-1), printCode=CodeZero, boxedCode=boxedCode, sizeCode=sizeCode} else *) case List.find(fn({typeConstr=tc, ...}, _) => sameTypeId(tcIdentifier(tsConstr tc), typeId)) typesAndAddresses of SOME({boxedCode, sizeCode, ...}, addr) => (* Mutually recursive. *) TypeValue.createTypeValue{eqCode=mkLoad(addr, l, baseEqLevel), printCode=CodeZero, boxedCode=boxedCode, sizeCode=sizeCode} | NONE => codeId(typeId, l) (* Filter out the ShortForm constructors. They arise in situations such as datatype t = A of int*int | B | C i.e. where we have only one non-nullary constructor and it is a tuple. In this case we can deal with all the nullary constructors simply by testing whether the two arguments are the same. We don't have to discriminate the individual cases. *) fun processConstrs [] = (* The last of the alternatives is false *) CodeZero | processConstrs (Value{class, access, typeOf, ...} :: rest) = let fun addPolymorphism c = if nTypeVars = 0 orelse justForEqualityTypes then c else mkEval(c, localArgList) val base = codeAccess(access, baseEqLevelP1) open ValueConstructor fun matches arg = mkEval(addPolymorphism(extractTest base), [arg]) in case class of Constructor{nullary=true, ...} => let (* Nullary constructors are represented either by short constants or by constant tuples depending on the rest of the datatype. If this is a short constant the pointer equality is sufficient. This appears to increase the code size but the test should be optimised away because it is applied to a constant. (The "injection function" of a nullary constructor is the constant that represents the value). We have to test the tags if it is not short because we can't guarantee that the constant tuple hasn't been duplicated. *) val isShort = mkIsShort(addPolymorphism(extractInjection base)) in mkIf(mkIf(isShort, CodeFalse, matches arg1), matches arg2, processConstrs rest) end | _ => (* We have to unwrap the value. *) let (* Get the constructor argument given the result type. We might actually be able to take the argument type off directly but there's some uncertainty about whether we use the same type variables for the constructors as for the datatype. (This only applies for polytypes). *) val resType = constructorResult(typeOf, List.map TypeVar argTypes) (* Code to extract the value. *) fun destruct argNo = mkEval(addPolymorphism(extractProjection(codeAccess(access, baseEqLevelP1))), [mkLoadParam(argNo, baseEqLevelP1, baseEqLevelP1)]) (* Test whether the values match. *) val eqValue = mkEval( makeEq(resType, baseEqLevelP1, getEqFnForID, argTypeMap), [destruct 0, destruct 1]) in (* We have equality if both values match this constructor and the values within the constructor match. *) mkIf(matches arg1, mkCand(matches arg2, eqValue), processConstrs rest) end end (* processConstrs assumes that if there are nullary constructors we have already tested for bitwise equality. We also do that if there is more than one constructor to try to speed up equality for deep structures. *) val eqCode = case vConstrs of [Value{class=Constructor{nullary=true, ...}, ...}] => CodeTrue | [_] => processConstrs vConstrs | _ => mkCor(mkEqualPointerOrWord(arg1, arg2), processConstrs vConstrs) in if null argTypes then (addr, mkProc(eqCode, 2, "eq-" ^ tcName tyConstr ^ "(2)", getClosure baseEqLevelP1, 0)) :: otherFns else (* Polymorphic. Add an extra inline functions. *) let val nArgs = List.length argTypes val nLevel = newLevel baseEqLevel val nnLevel = newLevel nLevel (* Call the second function with the values to be compared and the base types. *) val polyArgs = List.tabulate(nArgs, fn i => mkLoadParam(i, nnLevel, nLevel)) in (addr, mkInlproc( mkInlproc( mkEval(mkLoad(addr+1, nnLevel, baseEqLevel), [arg1, arg2] @ polyArgs), 2, "eq-" ^ tcName tyConstr ^ "(2)", getClosure nnLevel, 0), nArgs, "eq-" ^ tcName tyConstr ^ "(2)(P)", getClosure nLevel, 0)) :: (addr+1, mkProc(mkEnv(getCachedTypeValues argTypeMap, eqCode), 2+nTypeVars, "eq-" ^ tcName tyConstr ^ "()", getClosure baseEqLevelP1, 0)) :: otherFns end end else (* Not an equality type. This will not be called but it still needs to be a function to ensure it's valid inside mkMutualDecs. *) (addr, mkProc(CodeZero, 2, "no-eq", [], 0)) :: otherFns in List.foldl equalityForDatatype [] typesAndAddresses end (* Create a printer function for a datatype when the datatype is declared. We don't have to treat mutually recursive datatypes specially because this is called after the type IDs have been created. *) fun printerForDatatype(TypeConstrSet(typeCons as TypeConstrs{name, ...}, vConstrs), level, typeVarMap) = let val argCode = mkInd(0, arg1) and depthCode = mkInd(1, arg1) val nLevel = newLevel level val constrArity = tcArity typeCons val argTypes = List.tabulate(constrArity, fn _ => makeTv{value=EmptyType, level=generalisable, nonunifiable=false, equality=false, printable=false}) val (localArgList, innerLevel, newTypeVarMap) = case constrArity of 0 => ([], nLevel, typeVarMap) | _ => let val nnLevel = newLevel nLevel fun mkTcArgMap (argTypes, level, oldLevel) = let val nArgs = List.length argTypes val argAddrs = List.tabulate(nArgs, fn n => n) val args = List.map(fn addr => fn l => mkLoadParam(addr, l, oldLevel)) argAddrs in (ListPair.zipEq(argTypes, args), List.map (fn addr => mkLoadParam(addr, level, oldLevel)) argAddrs) end val (varToArgMap, localArgList) = mkTcArgMap(argTypes, nnLevel, nLevel) val addrs = ref 1 (* Make local declarations for any type values. *) fun mkAddr n = !addrs before (addrs := !addrs + n) in (localArgList, nnLevel, extendTypeVarMap(varToArgMap, mkAddr, nLevel, typeVarMap)) end (* If we have an expression as the argument we parenthesise it unless it is a simple string, a tuple, a record or a list. *) (* fun parenthesise p = let val test = case p of PrettyBlock(_, _, _, items) => ( case items of PrettyString first :: tl => not(null tl) andalso first <> "(" andalso first <> "{" andalso first <> "[" | _ => false ) | _ => false in if test then PrettyBlock(3, true, [], [ PrettyString "(", PrettyBreak(0, 0), p, PrettyBreak(0, 0), PrettyString ")" ]) else p end *) local fun eqStr (arg, str) = mkEqualPointerOrWord(arg, mkConst(toMachineWord str)) (* eqStr assumes that all occurrences of the same single character string are shared. *) val isNotNull = mkNot o mkIsShort fun testTag(arg, tagV) = (* Test the tag in the first word of the datatype. *) mkTagTest(mkInd(0, arg), tagV, maxPrettyTag) fun listHd x = mkVarField(0, x) and listTl x = mkVarField(1, x) in val parenCode = mkProc( mkIf( testTag(mkLoadArgument 0, tagPrettyBlock), (* then *) mkEnv( [mkDec(0, mkVarField(4, mkLoadArgument 0))], (* items *) mkIf ( (* not(null items) andalso not(null(tl items)) andalso not (isPrettyString(hd items) andalso bracket) *) mkCand( isNotNull(mkLoadLocal 0), mkCand( isNotNull (listTl(mkLoadLocal 0)), mkNot ( mkCand(testTag(listHd(mkLoadLocal 0), tagPrettyString), mkEnv( [mkDec(1, mkVarField(1, listHd(mkLoadLocal 0)))], mkCor(eqStr(mkLoadLocal 1, "("), mkCor(eqStr(mkLoadLocal 1, "{"), eqStr(mkLoadLocal 1, "["))) ) ) ) ) ), (* then: Parenthesise the argument. *) codePrettyBlock( 3, true, [], mkDatatype [ codePrettyString "(", mkDatatype [ codePrettyBreak(0, 0), mkDatatype [ mkLoadArgument 0, mkDatatype [ codePrettyBreak(0, 0), mkDatatype [codePrettyString ")", CodeZero ] ] ] ] ] ), (* else *) mkLoadArgument 0 ) ), (* else *) mkLoadArgument 0 ), 1, "parenthesise", [], 2) end fun printerForConstructors (Value{name, typeOf, access, class = Constructor{nullary, ...}, locations, ...} :: rest) = let (* The "value" for a value constructor is a tuple containing the test code, the injection and the projection functions. *) val constructorCode = codeAccess(access, innerLevel) (* If this is a polytype the fields in the constructor tuple are functions that first have to be applied to the type arguments to yield the actual injection/test/projection functions. For monotypes the fields contain the injection/test/projection functions directly. *) fun addPolymorphism c = if constrArity = 0 orelse justForEqualityTypes then c else mkEval(c, localArgList) open ValueConstructor val locProps = (* Get the declaration location. *) List.foldl(fn (DeclaredAt loc, _) => [ContextLocation loc] | (_, l) => l) [] locations val nameCode = codePrettyBlock(0, false, locProps, codeList([codePrettyString name], CodeZero)) val printCode = if nullary then (* Just the name *) nameCode else let val typeOfArg = constructorResult(typeOf, List.map TypeVar argTypes) val getValue = mkEval(addPolymorphism(extractProjection constructorCode), [argCode]) in codePrettyBlock(1, false, [], codeList( [ (* Put it in a block with the declaration location. *) nameCode, codePrettyBreak (1, 0), (* Print the argument and parenthesise it if necessary. *) mkEval(parenCode, [ mkEval( printerForType(typeOfArg, innerLevel, newTypeVarMap), [mkTuple[getValue, decDepth depthCode]] )] ) ], CodeZero)) end in (* If this was the last or only constructor we don't need to test. *) checkDepth(depthCode, 1, if null rest then printCode else let val testValue = mkEval(addPolymorphism(extractTest constructorCode), [argCode]) in mkIf(testValue, printCode, printerForConstructors rest) end, codePrettyString "...") end | printerForConstructors _ = raise InternalError ("No constructors:"^name) val printerCode = printerForConstructors vConstrs in (* Wrap this in the functions for the base types. *) if constrArity = 0 then mkProc(printerCode, 1, "print-"^name, getClosure innerLevel, 0) else mkProc(mkEnv(getCachedTypeValues newTypeVarMap, mkProc(printerCode, 1, "print-"^name, getClosure innerLevel, 0)), constrArity, "print"^name^"()", getClosure nLevel, 0) end (* Opaque matching and functor application create new type IDs using an existing type as implementation. The equality function is inherited whether the type was specified as an eqtype or not. The print function is no longer inherited. Instead a new reference is installed with a default print function. This hides the implementation. *) (* If this is a type function we're going to generate a new ref anyway so we don't need to copy it. *) fun codeGenerativeId{source=TypeId{idKind=TypeFn([], resType), ...}, isEq, mkAddr, level, ...} = let (* Monotype abbreviation. *) (* Create a new type value cache. *) val typeVarMap = defaultTypeVarMap(mkAddr, level) open TypeValue val eqCode = if not isEq then CodeZero else (* We need a function that takes two arguments rather than a single pair. *) makeEq(resType, level, fn (typeId, _, l) => codeId(typeId, l), typeVarMap) val boxedCode = boxednessForType(resType, level, fn (typeId, _, l) => codeId(typeId, l), typeVarMap) val sizeCode = sizeForType(resType, level, fn (typeId, _, l) => codeId(typeId, l), typeVarMap) in mkEnv( TypeVarMap.getCachedTypeValues typeVarMap, createTypeValue { eqCode = eqCode, boxedCode = boxedCode, sizeCode = sizeCode, printCode = mkAllocateWordMemory( mkConst (toMachineWord 1), mkConst (toMachineWord mutableFlags), codePrintDefault) }) end | codeGenerativeId{source=TypeId{idKind=TypeFn(argTypes, resType), ...}, isEq, mkAddr, level, ...} = let (* Polytype abbreviation: All the entries in the tuple are functions that must be applied to the base type values when the type constructor is used. *) (* Create a new type value cache. *) val typeVarMap = defaultTypeVarMap(mkAddr, level) val nArgs = List.length argTypes fun createCode(makeCode, name) = let val nLevel = newLevel level val addrs = ref 0 fun mkAddr n = !addrs before (addrs := !addrs + n) local val args = List.tabulate(nArgs, fn addr => fn l => mkLoadParam(addr, l, nLevel)) in val typeEnv = ListPair.zipEq(argTypes, args) end val argTypeMap = extendTypeVarMap(typeEnv, mkAddr, nLevel, typeVarMap) val innerFnCode = makeCode(nLevel, argTypeMap) in mkProc(mkEnv(getCachedTypeValues argTypeMap, innerFnCode), nArgs, name, getClosure nLevel, !addrs) end open TypeValue (* Create a print function.*) val printCode = createCode(fn _ => codePrintDefault, "print-helper()") and eqCode = if not isEq then CodeZero else createCode(fn(nLevel, argTypeMap) => makeEq(resType, nLevel, fn (typeId, _, l) => codeId(typeId, l), argTypeMap), "equality()") and boxedCode = createCode(fn(nLevel, argTypeMap) => boxednessForType(resType, nLevel, fn (typeId, _, l) => codeId(typeId, l), argTypeMap), "boxedness()") and sizeCode = createCode(fn(nLevel, argTypeMap) => sizeForType(resType, nLevel, fn (typeId, _, l) => codeId(typeId, l), argTypeMap), "size()") in mkEnv( TypeVarMap.getCachedTypeValues typeVarMap, createTypeValue { eqCode = eqCode, boxedCode = boxedCode, printCode = mkAllocateWordMemory( mkConst (toMachineWord 1), mkConst (toMachineWord mutableFlags), printCode), sizeCode = sizeCode }) end | codeGenerativeId{source=sourceId, isDatatype, mkAddr, level, ...} = let (* Datatype. This is the same for monotype and polytypes except for the print fn. *) (* We hide the print function if the target is just a type name but if the target is a datatype it's probably better to have a print function. We inherit it from the source although that may expose the representation of other types. e.g. structure S:> sig type t datatype s = A of t end = ... *) open TypeValue val { dec, load } = multipleUses (codeId(sourceId, level), fn () => mkAddr 1, level) val loadLocal = load level val arity = case sourceId of TypeId{idKind=Bound{arity, ...},...} => arity | TypeId{idKind=Free{arity, ...},...} => arity | TypeId{idKind=TypeFn _,...} => raise InternalError "Already checked" val printFn = if isDatatype then mkLoadOperation(LoadStoreMLWord{isImmutable=false}, extractPrinter loadLocal, CodeZero) else if arity = 0 then codePrintDefault else mkProc(codePrintDefault, arity, "print-helper()", [], 0) val printCode = mkAllocateWordMemory( mkConst (toMachineWord 1), mkConst (toMachineWord mutableFlags), printFn) in mkEnv( dec, createTypeValue { eqCode = extractEquality loadLocal, printCode = printCode, boxedCode = extractBoxed loadLocal, sizeCode = extractSize loadLocal } ) end (* Create the equality and type functions for a set of mutually recursive datatypes. *) fun createDatatypeFunctions( typeDatalist: {typeConstr: typeConstrSet, eqStatus: bool, boxedCode: codetree, sizeCode: codetree } list, mkAddr, level, typeVarMap, makePrintFunction) = let (* Each entry has an equality function and a ref to a print function. The print functions for each type needs to indirect through the refs when printing other types so that if a pretty printer is later installed for one of the types the others will use the new pretty printer. That means that the code has to be produced in stages. *) (* Create the equality functions. Because mutual decs can only be functions we can't create the typeIDs themselves as mutual declarations. *) local (* If this is polymorphic make two addresses, one for the returned equality function and one for the inner function. *) fun makeEqAddr{typeConstr=TypeConstrSet(tyConstr, _), ...} = mkAddr(if tcArity tyConstr = 0 then 1 else 2) in val eqAddresses = List.map makeEqAddr typeDatalist (* Make addresses for the equalities. *) end val equalityFunctions = mkMutualDecs(equalityForDatatypes(typeDatalist, eqAddresses, level, typeVarMap)) (* Create the typeId values and set their addresses. The print function is initially set as zero. *) local fun makeTypeId({typeConstr, boxedCode, sizeCode, ...}, eqAddr) = let val var = vaLocal(idAccess(tcIdentifier(tsConstr typeConstr))) val newAddr = mkAddr 1 open TypeValue val idCode = createTypeValue { eqCode=mkLoadLocal eqAddr, printCode= mkAllocateWordMemory( mkConst (toMachineWord 1), mkConst (toMachineWord mutableFlags), CodeZero (* Temporary - replaced by setPrinter. *)), boxedCode = boxedCode, sizeCode = sizeCode } in #addr var := newAddr; #level var:= level; mkDec(newAddr, idCode) end in val typeIdCode = ListPair.map makeTypeId (typeDatalist, eqAddresses) end (* Create the print functions and set the printer code for each typeId. *) local fun setPrinter{typeConstr as TypeConstrSet(tCons as TypeConstrs{identifier, ...}, _), ...} = let val arity = tcArity tCons val printCode = if makePrintFunction then printerForDatatype(typeConstr, level, typeVarMap) else if arity = 0 then codePrintDefault else mkProc(codePrintDefault, arity, "print-printdefault", [], 0) in mkNullDec( mkStoreOperation(LoadStoreMLWord{isImmutable=false}, TypeValue.extractPrinter(codeId(identifier, level)), CodeZero, printCode)) end in val printerCode = List.map setPrinter typeDatalist end in equalityFunctions :: typeIdCode @ printerCode end (* Exported function. Returns a function from an ML pair of values to bool. N.B. This differs from the functions in the typeID which take a Poly pair. *) fun equalityForType(ty: types, level: level, typeVarMap: typeVarMap): codetree = let val nLevel = newLevel level (* The final result function must take a single argument. *) val resultCode = makeEq(ty, nLevel, fn (typeId, _, l) => codeId(typeId, l), typeVarMap) in (* We need to wrap this up in a new inline function. *) mkInlproc(mkEval(resultCode, [mkInd(0, arg1), mkInd(1, arg1)]), 1, "equality", getClosure nLevel, 0) end (* This code is used when the type checker has to construct a unique monotype because a type variable has escaped to the top level. The equality code always returns true and the printer prints "?". *) fun codeForUniqueId() = let open TypeValue val alwaysTrue = mkProc(CodeTrue, 2, "codeForUniqueId-equal", [], 0) val printCode = mkAllocateWordMemory( mkConst (toMachineWord 1), mkConst (toMachineWord mutableFlags), codePrintDefault) in createTypeValue{ eqCode = alwaysTrue, printCode = printCode, boxedCode = boxedEither, sizeCode = singleWord } end val noEquality = mkProc(CodeFalse, 2, "noEquality", [], 0) (* Since we don't have a way of writing a "printity" type variable there are cases when the printer will have to fall back to this. e.g. if we have a polymorphic printing function as a functor argument. *) val noPrinter = codePrintDefault (* If this is a polymorphic value apply it to the type instance. *) fun applyToInstance'([], level, _, code) = code level (* Monomorphic. *) | applyToInstance'(sourceTypes, level, polyVarMap, code) = let (* If we need either the equality or print function we generate a new entry and ignore anything in the cache. *) fun makePolyParameter {value=t, equality, printity} = if equality orelse printity then let open TypeValue fun getTypeValueForID(typeId, _, l) = codeId(typeId, l) val eqCode = if equality then makeEq(t, level, fn (typeId, _, l) => codeId(typeId, l), polyVarMap) else noEquality val boxedCode = boxednessForType(t, level, getTypeValueForID, polyVarMap) val printCode = if printity then printerForType(t, level, polyVarMap) else noPrinter val sizeCode = sizeForType(t, level, getTypeValueForID, polyVarMap) in createTypeValue{ eqCode=eqCode, printCode=printCode, boxedCode=boxedCode, sizeCode=sizeCode} end else (* If we don't require the equality or print function we can use the cache. *) case findCachedTypeCode(polyVarMap, t) of SOME (code, _) => code level | NONE => let val maxCache = getMaxDepth polyVarMap (t, 1) val cacheEntry = List.nth(polyVarMap, List.length polyVarMap - maxCache) val { cache, mkAddr, level=decLevel, ...} = cacheEntry local open TypeValue val boxedCode = boxednessForType(t, decLevel, fn (typeId, _, l) => codeId(typeId, l), polyVarMap) val sizeCode = sizeForType(t, decLevel, fn (typeId, _, l) => codeId(typeId, l), polyVarMap) in val typeValue = createTypeValue{ eqCode=noEquality, printCode=noPrinter, boxedCode=boxedCode, sizeCode=sizeCode} end (* Make a new entry and put it in the cache. *) val decAddr = mkAddr 1 val () = cache := {decCode = mkDec(decAddr, typeValue), typeOf = t, address = decAddr } :: !cache in mkLoad(decAddr, level, decLevel) end in mkEval(code level, List.map makePolyParameter sourceTypes) end (* For now limit this to equality types. *) fun applyToInstance(sourceTypes, level, polyVarMap, code) = applyToInstance'( List.filter(fn {equality, ...} => not justForEqualityTypes orelse equality) sourceTypes, level, polyVarMap, code) structure Sharing = struct type typeId = typeId type codetree = codetree type types = types type typeConstrs= typeConstrs type typeConstrSet=typeConstrSet type typeVarForm=typeVarForm type typeVarMap = typeVarMap type codeBinding = codeBinding type level = level end end; diff --git a/mlsource/MLCompiler/TYPE_TREE.ML b/mlsource/MLCompiler/TYPE_TREE.ML index e2314b42..27a35ec9 100644 --- a/mlsource/MLCompiler/TYPE_TREE.ML +++ b/mlsource/MLCompiler/TYPE_TREE.ML @@ -1,3264 +1,3264 @@ (* Original Poly version: Title: Operations on type structures. Author: Dave Matthews, Cambridge University Computer Laboratory Copyright Cambridge University 1985 ML translation and other changes: Copyright (c) 2000 Cambridge University Technical Services Limited Further development: Copyright (c) 2000-9, 2012-2018, 2020 David C.J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) functor TYPE_TREE ( structure LEX : LEXSIG structure STRUCTVALS : STRUCTVALSIG; structure PRETTY : PRETTYSIG structure CODETREE : CODETREESIG where type machineWord = Address.machineWord structure EXPORTTREE: EXPORTTREESIG; - structure DEBUG: DEBUGSIG + structure DEBUG: DEBUG structure UTILITIES : sig val mapTable: ('a * 'a -> bool) -> {enter: 'a * 'b -> unit, lookup: 'a -> 'b option} val splitString: string -> { first:string, second:string } end; structure MISC : sig exception InternalError of string; val lookupDefault : ('a -> 'b option) -> ('a -> 'b option) -> 'a -> 'b option end; sharing LEX.Sharing = PRETTY.Sharing = EXPORTTREE.Sharing = STRUCTVALS.Sharing = CODETREE.Sharing ) : TYPETREESIG = (*****************************************************************************) (* TYPETREE functor body *) (*****************************************************************************) struct open MISC; open PRETTY; open STRUCTVALS; open LEX; open UTILITIES; open CODETREE; open EXPORTTREE (* added 16/4/96 SPF *) fun sameTypeVar (TypeVar x, TypeVar y) = sameTv (x, y) | sameTypeVar _ = false; fun isTypeVar (TypeVar _) = true | isTypeVar _ = false; fun isFunctionType (FunctionType _) = true | isFunctionType _ = false; fun isEmpty EmptyType = true | isEmpty _ = false; fun isBadType BadType = true | isBadType _ = false; val emptyType = EmptyType; fun typesTypeVar (TypeVar x) = x | typesTypeVar _ = raise Match; fun typesFunctionType (FunctionType x) = x | typesFunctionType _ = raise Match; (* This is really left over from an old definition. *) fun tcEquivalent(TypeConstrs{identifier = TypeId {idKind = TypeFn(_, result), ...}, ...}) = result | tcEquivalent _ = raise InternalError "tcEquivalent: Not a type function" (* A type construction is the application of a type constructor to a sequence of types to yield a type. A construction may have a nil list if it is a single type identifier such as ``int''. *) (* When a type constructor is encountered in the first pass this entry is put in. Subsequently a type constructor entry will be assigned to it so that the types can be checked. *) (*************) fun mkTypeVar (level, equality, nonunifiable, printable) = TypeVar (makeTv {value=emptyType, level=level, equality=equality, nonunifiable=nonunifiable, printable=printable}); fun mkTypeConstruction (name, typc, args, locations) = TypeConstruction {name = name, constr = typc, args = args, locations = locations} local (* Turn a tuple into a record of the form {1=.., 2=... }*) fun maptoRecord ([], _) = [] | maptoRecord (H::T, i) = {name=Int.toString i, typeof=H} :: maptoRecord (T,i+1) in fun mkProductType (typel: types list) = let val fields = maptoRecord (typel, 1) in LabelledType {recList = fields, fullList = FieldList(List.map #name fields, true)} end end fun mkFunctionType (arg, result) = FunctionType {arg = arg, result = result}; fun mkOverloadSet [constr] = (* If there is just a single constructor in the set we make a type construction from it. *) mkTypeConstruction(tcName constr, constr, nil, []) | mkOverloadSet constrs = let (* Make a type variable and point this at the overload set so we can narrow down the overloading. *) val var = mkTypeVar (generalisable, false, false, false) val set = OverloadSet {typeset=constrs}; in tvSetValue (typesTypeVar var, set); var end fun mkLabelled (l, frozen) = let val final = FieldList(map #name l, frozen) val lab = LabelledType {recList = l, fullList = if frozen then final else FlexibleList(ref final) } in if frozen then lab else let (* Use a type variable so that the record can be expanded. This also provides a model (equality etc). for any fields that are added later. *) val var = mkTypeVar (generalisable, false, false, false) val () = if isTypeVar var then tvSetValue (typesTypeVar var, lab) else (); in var end end (* Must remove leading zeros because the labels are compared by string comparison. *) fun mkLabelEntry (name, t) = let fun stripZeros s = if size s <= 1 orelse String.str(String.sub(s, 0)) <> "0" then s else stripZeros (String.substring(s, 1, size s-1)); in {name = stripZeros name, typeof = t} end; (* Functions to construct the run-time representations of type constructor values, type values and value constructors. These are all tuples and centralising the code here avoids having the offsets as integers at various places. Monotype constructor and type values are almost the same except that type values have the printer entry as the function whereas monotype constructors have the print entry as a ref pointing to the function, allowing addPrettyPrint to set a printer for the type. The entries for polytypes are functions that take the type values as arguments and return the corresponding values. *) structure TypeValue = struct val equalityOffset = 0 and printerOffset = 1 and boxnessOffset = 2 and sizeOffset = 3 local (* Values used to represent boxness. *) val boxedRepNever = 0w1 (* Never boxed, always tagged e.g. bool *) and boxedRepAlways = 0w2 (* Always boxed, never tagged e.g. function types *) and boxedRepEither = 0w3 (* Either boxed or tagged e.g. (arbitrary precision) int *) fun make n = mkConst(Address.toMachineWord n) fun isCode n = mkInlproc(mkEqualTaggedWord(mkLoadArgument 0, make n), 1, "test-box", [], 0) in val boxedNever = make boxedRepNever and boxedAlways = make boxedRepAlways and boxedEither = make boxedRepEither (* Test for boxedness. This must be applied to the value extracted from the "boxedness" field after applying to any base type arguments in the case of a polytype constructor. *) val isBoxedNever = isCode boxedRepNever and isBoxedAlways = isCode boxedRepAlways and isBoxedEither = isCode boxedRepEither end (* Sizes are always a single word. *) val singleWord = mkConst(Address.toMachineWord 0w1) fun extractEquality idCode = mkInd(equalityOffset, idCode) and extractPrinter idCode = mkInd(printerOffset, idCode) and extractBoxed idCode = mkInd(boxnessOffset, idCode) and extractSize idCode = mkInd(sizeOffset, idCode) fun createTypeValue{eqCode, printCode, boxedCode, sizeCode} = mkTuple[eqCode, printCode, boxedCode, sizeCode] end (* Value constructors are represented by tuples, either pairs for nullary constructors or triples for constructors with arguments. For nullary functions the "injection" function is actually the value itself. If this is a polytype all the entries are functions that take the type values for the base types as arguments. *) structure ValueConstructor = struct val testerOffset = 0 val injectorOffset = 1 val projectorOffset = 2 fun extractTest constrCode = mkInd(testerOffset, constrCode) and extractInjection constrCode = mkInd(injectorOffset, constrCode) and extractProjection constrCode = mkInd(projectorOffset, constrCode) fun createValueConstr{testMatch, injectValue, projectValue} = mkTuple[testMatch, injectValue, projectValue] fun createNullaryConstr{ testMatch, constrValue } = mkTuple[testMatch, constrValue] end (* Eqtypes with built-in equality functions. The printer functions are all replaced in the basis. *) local open Address PRETTY TypeValue fun defaultMonoTypePrinter _ = PrettyString "?" fun defaultPolyTypePrinter _ _ = PrettyString "?" fun eqAndPrintCode (eqCode, nArgs, boxed) = let val code = if nArgs = 0 then createTypeValue{ eqCode=eqCode, printCode=mkConst (toMachineWord (ref defaultMonoTypePrinter)), boxedCode = boxed, sizeCode = singleWord } else createTypeValue{ eqCode=mkInlproc(eqCode, nArgs, "eq-helper()", [], 0), printCode=mkConst (toMachineWord (ref defaultPolyTypePrinter)), boxedCode = mkInlproc(boxed, nArgs, "boxed-helper()", [], 0), sizeCode = mkInlproc(singleWord, nArgs, "size-helper()", [], 0) } in Global (genCode(code, [], 0) ()) end fun makeConstr(name, fullName, eqFun, boxed) = makeTypeConstructor (name, [], makeFreeId(0, eqAndPrintCode(eqFun, 0, boxed), true, basisDescription fullName), [DeclaredAt inBasis]) (* since code generator relies on these representations, we may as well export them *) (* Strings are now always vectors whose first word is the length. The old special case for single-character strings has been removed. *) local val stringEquality = mkInlproc( (* This previously checked for pointer equality first. That has been removed. Test the lengths first and only do the byte comparison if they are the same. This seems to save more time than including the length word in the byte comparison. *) mkCand( mkEqualPointerOrWord( (* Because we're not actually tagging these we use pointerEq here. *) mkLoadOperation(LoadStoreUntaggedUnsigned, mkLoadArgument 0, CodeZero), mkLoadOperation(LoadStoreUntaggedUnsigned, mkLoadArgument 1, CodeZero)), mkBlockOperation{kind=BlockOpEqualByte, leftBase=mkLoadArgument 0, rightBase=mkLoadArgument 1, leftIndex=mkConst(toMachineWord wordSize), rightIndex=mkConst(toMachineWord wordSize), (* Use argument 1 here rather than 0. We could use either but this works better when we're using equality for pattern matching since it gets the length of the constant string. It also works better for the, to me, more natural ordering of variable=constant. *) length=mkLoadOperation(LoadStoreUntaggedUnsigned, mkLoadArgument 1, CodeZero) } ), 2, "stringEquality", [], 0) in val stringEquality = stringEquality end local (* Arbitrary precision values are normalised so if a value can be represented as a tagged fixed precision value it will be. Unlike strings it is much more likely that the value will be short so we generate equality as a test that handles the short case as inline code and the long case as a function call. If either argument is a short constant this will be optimised away so the test will reduce to a test on whether the value equals the constant. *) val intEquality = mkEnv( [mkDec(0, (* Long-form equality - should not be inlined. *) mkProc( (* Equal if signs are the same ... *) mkCand( mkEqualTaggedWord( mkUnary(BuiltIns.MemoryCellFlags, mkLoadArgument 0), mkUnary(BuiltIns.MemoryCellFlags, mkLoadArgument 1) ), mkEnv( [mkDec(0, mkUnary(BuiltIns.MemoryCellLength, mkLoadArgument 1))], mkCand( (* ... and the lengths are equal ... *) mkEqualTaggedWord( mkUnary(BuiltIns.MemoryCellLength, mkLoadArgument 0), mkLoadLocal 0 ), (* ... and they're byte-wise equal .*) mkBlockOperation{kind=BlockOpEqualByte, leftBase=mkLoadArgument 0, rightBase=mkLoadArgument 1, leftIndex=CodeZero, rightIndex=CodeZero, length=mkBinary(BuiltIns.WordArith BuiltIns.ArithMult, mkConst(toMachineWord RunCall.bytesPerWord), mkLoadLocal 0)} ) ) ), 2, "arbitraryPrecisionEquality", [], 1) ) ], mkInlproc( mkCor( (* Either they're equal... *) (* N.B. The values could be short or long. That's particularly important if we have a series of tests against short constants. If we convert it to an indexed case we MUST check that the value is short before computing the index. *) mkEqualPointerOrWord(mkLoadArgument 0, mkLoadArgument 1), (* .. or if either is short the result is false ... *) mkCand( mkCand( mkNot(mkIsShort(mkLoadArgument 0)), mkNot(mkIsShort(mkLoadArgument 1)) ), (* ... otherwise we have to test the vectors. *) mkEval(mkLoadClosure 0, [mkLoadArgument 0, mkLoadArgument 1]) ) ), 2, "intInfEquality", [mkLoadLocal 0], 0) ) in (* Code-generate the function and return the inline part. We need to set the maximum inline size here to ensure the long form code is not inlined. It would be better to have a way of turning off inlining for specific functions. *) val intEquality = genCode(intEquality, [Universal.tagInject DEBUG.maxInlineSizeTag 5], 1) () end in val fixedIntConstr = makeConstr("int", "FixedInt.int", equalTaggedWordFn, boxedNever) (* Fixed precision is always short *) val intInfConstr = makeConstr("int", "IntInf.int", intEquality, boxedEither) val charConstr = makeConstr("char", "char", equalTaggedWordFn, boxedNever) (* Always short *) val stringConstr = makeConstr("string", "string", stringEquality, boxedEither (* Single chars are unboxed. *)) val wordConstr = makeConstr("word", "word", equalTaggedWordFn, boxedNever) (* Ref is a datatype with a single constructor. The constructor is added in INITIALISE. Equality is special for "'a ref", "'a array" and "'a Array2.array". They permit equality even if the 'a is not an eqType. *) val refConstr = makeTypeConstructor ("ref", [makeTv {value=EmptyType, level=generalisable, equality=false, nonunifiable=false, printable=false}], makeFreeId(1, eqAndPrintCode(equalPointerOrWordFn, 1, boxedAlways), true, basisDescription "ref"), [DeclaredAt inBasis]); val arrayConstr = makeTypeConstructor ("array", [makeTv {value=EmptyType, level=generalisable, equality=false, nonunifiable=false, printable=false}], makeFreeId(1, eqAndPrintCode(equalPointerOrWordFn, 1, boxedAlways), true, basisDescription "Array.array"), [DeclaredAt inBasis]); val array2Constr = makeTypeConstructor ("array", [makeTv {value=EmptyType, level=generalisable, equality=false, nonunifiable=false, printable=false}], makeFreeId(1, eqAndPrintCode(equalPointerOrWordFn, 1, boxedAlways), true, basisDescription "Array2.array"), [DeclaredAt inBasis]); val byteArrayConstr = makeTypeConstructor ("byteArray", [], makeFreeId(0, eqAndPrintCode(equalPointerOrWordFn, 0, boxedAlways), true, basisDescription "byteArray"), [DeclaredAt inBasis]); (* Bool is a datatype. The constructors are added in INITIALISE. *) val boolConstr = makeTypeConstructor ("bool", [], makeFreeId(0, eqAndPrintCode(equalTaggedWordFn, 0, boxedNever), true, basisDescription "bool"), [DeclaredAt inBasis]); end (* These polytypes allow equality even if the type argument is not an equality type. *) fun isPointerEqType id = sameTypeId (id, tcIdentifier refConstr) orelse sameTypeId (id, tcIdentifier arrayConstr) orelse sameTypeId (id, tcIdentifier array2Constr) orelse sameTypeId (id, tcIdentifier byteArrayConstr) (* Non-eqtypes *) local open Address PRETTY TypeValue fun makeType(name, descr, boxed) = let fun defaultPrinter _ = PrettyString "?" val code = createTypeValue{ eqCode=CodeZero (* No equality. *), printCode=mkConst (toMachineWord (ref defaultPrinter)), boxedCode=boxed, sizeCode=singleWord } in makeTypeConstructor ( name, [], makeFreeId(0, Global (genCode(code, [], 0) ()), false, descr), [DeclaredAt inBasis]) end in val realConstr = makeType("real", basisDescription "real", boxedAlways(* Currently*)) (* Not an eqtype in ML97. *) (* Short real: Real32.real *) val floatConstr = makeType("real", basisDescription "real", if RunCall.bytesPerWord <= 0w4 then boxedAlways else boxedNever) val exnConstr = makeType("exn", basisDescription "exn", boxedAlways); (* "undefConstr" is used as a place-holder during parsing for the actual type constructor. If the type constructor is not found this may appear in an error message. *) val undefConstr = makeType("undefined", { location = inBasis, description = "Undefined", name = "undefined" }, boxedEither); end (* The unit type is equivalent to the empty record. *) val unitConstr = makeTypeConstructor ("unit", [], makeTypeFunction({ location = inBasis, description = "unit", name = "unit" }, ([], LabelledType {recList = [], fullList = FieldList([], true)})), [DeclaredAt inBasis]); (* Type identifiers bound to standard type constructors. *) val unitType = mkTypeConstruction ("unit", unitConstr, [], []) val fixedIntType = mkTypeConstruction ("int", fixedIntConstr, [], []) val stringType = mkTypeConstruction ("string", stringConstr, [], []) val boolType = mkTypeConstruction ("bool", boolConstr, [], []) val exnType = mkTypeConstruction ("exn", exnConstr, [], []) fun isUndefined cons = sameTypeId (tcIdentifier cons, tcIdentifier undefConstr); val isUndefinedTypeConstr = isUndefined (* Test if a type is the undefined constructor. *) fun isUndefinedType(TypeConstruction{constr, ...}) = isUndefined constr | isUndefinedType _ = false (* Similar to alphabetic ordering except that shorter labels come before longer ones. This has the advantage that numerical labels are compared by their numerical order i.e. 1 < 2 < 10 whereas alphabetic ordering puts "1" < "10" < "2". *) fun compareLabels (a : string, b : string) : int = if size a = size b then if a = b then 0 else if a < b then ~1 else 1 else if size a < size b then ~1 else 1; (* Sort using the label ordering. A simple sort routine - particularly if the list is already sorted. *) fun sortLabels [] = [] | sortLabels (s::rest) = let fun enter s _ [] = [s] | enter s name (l as ( (h as {name=hname, ...}) :: t)) = let val comp = compareLabels (name, hname); in if comp <= 0 then s :: l else h :: enter s name t end; in enter s (#name s) (sortLabels rest) end (* Chains down a list of type variables returning the type they are bound to. As a side-effect it also points all the type variables at this type to reduce the need for future chaining and to free unused type variables. Normally a type variable points to at most one other, which then points to "empty". However if we have unified two type variables by pointing one at the other, there may be type variables which pointed to the first and which cannot be found and redirected at the second until they themselves are examined. *) fun eventual (t as (TypeVar tv)) : types = let (* Note - don't change the level/copy information - the only type variable with this correct is the one at the end of the list. *) val oldVal = tvValue tv val newVal = eventual oldVal; (* Search that *) in (* Update the type variable to point to the last in the chain. We don't do this if the value hasn't changed. The reason for that was that assignment to refs in the database in the old persistent store system was very expensive and we wanted to avoid unnecessary assignments. This special case could probably be removed. *) if PolyML.pointerEq(oldVal, newVal) then () else tvSetValue (tv, newVal); (* Put it on *) case newVal of EmptyType => t (* Not bound to anything - return the type variable *) | LabelledType (r as { recList, fullList }) => if List.length recList = List.length(recordFields r) then (* All the generic fields are present so we don't need to do anything. *) if recordIsFrozen r then newVal else t else (* We need to add fields from the generic. *) let (* Add any fields from the generic that aren't present in this instance. *) fun createNewField name = { name = name, (* The new type variable has to be created with the same properties as if we had first generalised it from the generic and then unified with this instance. The level is inherited from the instance since the generic will always have level = generalisable. Nonunifiable must be false. *) typeof = mkTypeVar (tvLevel tv, tvEquality tv, false, tvPrintity tv)} fun addToInstance([], []) = [] | addToInstance(generic :: geRest, []) = createNewField generic :: addToInstance(geRest, []) | addToInstance([], instance) = instance (* This case can occur if we are producing an error message because of a type-incorrect program so we just ignore it. *) | addToInstance(generic :: geRest, inst as instance :: iRest) = let val order = compareLabels (generic, #name instance); in if order = 0 (* Equal *) then instance :: addToInstance(geRest, iRest) else if order < 0 (* generic name < instance name *) then createNewField generic :: addToInstance(geRest, inst) else (* This is another case that can occur with type-incorrect code. *) instance :: addToInstance(generic :: geRest, iRest) end val newList = addToInstance(recordFields r, recList) val newRecord = LabelledType {recList = newList, fullList = fullList} in tvSetValue(tv, newRecord); if recordIsFrozen r then newRecord else t end | OverloadSet _ => t (* Return the set of types. *) | _ => newVal (* Return the type it is bound to *) end | eventual t (* not a type variable *) = t; (* Apply a function to every element of a type. *) fun foldType f = let fun foldT typ v = let val t = eventual typ; val res = f t v; (* Process this entry. *) in case t of TypeVar tv => foldT (tvValue tv) res | TypeConstruction {args, ...} => (* Then process the arguments. *) List.foldr (fn (t, v) => foldT t v) res args | FunctionType {arg, result} => foldT arg (foldT result res) | LabelledType {recList,...} => List.foldr (fn ({ typeof, ... }, v) => foldT typeof v) res recList | BadType => res | EmptyType => res | OverloadSet _ => res end in foldT end; (* Checks to see whether a labelled record is in the form of a product i.e. 1=, 2= We only need this for prettyprinting. Zero-length records (i.e. unit) and singleton records are not considered as tuples. *) fun isProductType(LabelledType(r as {recList=recList as _::_::_, ...})) = let fun isRec [] _ = true | isRec ({name, ...} :: l) n = name = Int.toString n andalso isRec l (n+1) in recordIsFrozen r andalso isRec recList 1 end | isProductType _ = false; (* Test to see is a type constructor is in an overload set. *) fun isInSet(tcons: typeConstrs, (H::T): typeConstrs list) = sameTypeId (tcIdentifier tcons, tcIdentifier H) orelse isInSet(tcons, T) | isInSet(_, []: typeConstrs list) = false val prefInt = ref fixedIntConstr (* Returns the preferred overload if there is one. *) fun preferredOverload typeset = if isInSet(!prefInt, typeset) then SOME(!prefInt) else if isInSet(realConstr, typeset) then SOME realConstr else if isInSet(wordConstr, typeset) then SOME wordConstr else if isInSet(charConstr, typeset) then SOME charConstr else if isInSet(stringConstr, typeset) then SOME stringConstr else NONE fun setPreferredInt c = prefInt := c fun equalTypeIds(x, y) = let (* True if two types are equal. *) fun equalTypes (TypeConstruction{constr=xVal, args=xArgs, ...}, TypeConstruction{constr=yVal, args=yArgs, ...}) = equalTypeIds(tcIdentifier xVal, tcIdentifier yVal) andalso equalTypeLists (xArgs, yArgs) | equalTypes (FunctionType x, FunctionType y) = equalTypes (#arg x, #arg y) andalso equalTypes (#result x, #result y) | equalTypes (LabelledType x, LabelledType y) = recordIsFrozen x andalso recordIsFrozen y andalso equalRecordLists (#recList x, #recList y) | equalTypes (TypeVar x, TypeVar y) = sameTv (x, y) | equalTypes (EmptyType, EmptyType) = true | equalTypes _ = false and equalTypeLists ([], []) = true | equalTypeLists (x::xs, y::ys) = equalTypes(x, y) andalso equalTypeLists (xs, ys) | equalTypeLists _ = false and equalRecordLists ([], []) = true | equalRecordLists (x::xs, y::ys) = #name x = #name y andalso equalTypes(#typeof x, #typeof y) andalso equalRecordLists (xs, ys) | equalRecordLists _ = false in case (x, y) of (TypeId{idKind=TypeFn(_, xEquiv), ...}, TypeId{idKind=TypeFn(_, yEquiv), ...}) => equalTypes(xEquiv, yEquiv) | _ => sameTypeId(x, y) end (* See if the types are the same. This is a bit of a fudge, but saves carrying around a flag saying whether the structures were copied. This is only an optimisation. If the values are different it will not go wrong. *) val identical : types * types -> bool = PolyML.pointerEq and identicalConstr : typeConstrs * typeConstrs -> bool = PolyML.pointerEq and identicalList : 'a list * 'a list -> bool = PolyML.pointerEq (* Copy a type, avoiding copying type structures unnecessarily. Used to make new type variables for all distinct type variables when generalising polymorphic functions, and to make new type stamps for type constructors when generalising signatures. *) fun copyType (at, copyTypeVar, copyTypeConstr) = let fun copyList [] = [] | copyList (l as (h :: t)) = let val h' = copyType (h, copyTypeVar, copyTypeConstr); val t' = copyList t; in if identical (h', h) andalso identicalList (t', t) then l else h' :: t' end (* copyList *); fun copyRecordList [] = [] | copyRecordList (l as ({name, typeof} :: t)) = let val typeof' = copyType (typeof, copyTypeVar, copyTypeConstr); val t' = copyRecordList t; in if identical (typeof', typeof) andalso identicalList (t', t) then l else {name=name, typeof=typeof'} :: t' end (* copyList *); val atyp = eventual at; in case atyp of TypeVar _ => (* Unbound type variable, flexible record or overloading. *) copyTypeVar atyp | TypeConstruction {constr, args, locations, ...} => let val copiedArgs = copyList args; val copiedConstr = copyTypeConstr constr; (* Use the name from the copied constructor. This will normally be the same as the original EXCEPT in the case where we are using copyType to generate copies of the value constructors of replicated datatypes. *) val copiedName = tcName copiedConstr in if identicalList (copiedArgs, args) andalso identicalConstr (copiedConstr, constr) then atyp else (* Must copy it. *) mkTypeConstruction (copiedName, copiedConstr, copiedArgs, locations) end | FunctionType {arg, result} => let val copiedArg = copyType (arg, copyTypeVar, copyTypeConstr); val copiedRes = copyType (result, copyTypeVar, copyTypeConstr); in if identical (copiedArg, arg) andalso identical (copiedRes, result) then atyp else FunctionType {arg = copiedArg, result = copiedRes} end | LabelledType {recList, fullList} => (* Rigid labelled records only. Flexible ones are treated as type vars. *) let val copiedList = copyRecordList recList in if identicalList (copiedList, recList) then atyp else LabelledType {recList = copiedList, fullList = fullList} end | EmptyType => EmptyType | BadType => BadType | OverloadSet _ => raise InternalError "copyType: OverloadSet found" end (* copyType *); (* Copy a type constructor if it is Bound and in the required range. If this refers to a type function copies that as well. Does not copy value constructors. *) fun copyTypeConstrWithCache (tcon, typeMap, _, mungeName, cache) = case tcIdentifier tcon of TypeId{idKind = TypeFn(args, equiv), description, access, ...} => let val copiedEquiv = copyType(equiv, fn x => x, fn tcon => copyTypeConstrWithCache (tcon, typeMap, fn x => x, mungeName, cache)) in if identical (equiv, copiedEquiv) then tcon (* Type is identical and we don't want to change the name. *) else (* How do we find a type function? *) makeTypeConstructor (mungeName(tcName tcon), args, TypeId { access = access, description = description, idKind = TypeFn(args, copiedEquiv)}, tcLocations tcon) end | id => ( case typeMap id of NONE => ( (*print(concat[tcName tcon, " not copied\n"]);*) tcon (* No change *) ) | SOME newId => let val name = #second(splitString (tcName tcon)) (* We must only match here if they're really the same. *) fun cacheMatch tc = equalTypeIds(tcIdentifier tc, newId) andalso #second(splitString(tcName tc)) = name in case List.find cacheMatch cache of SOME tc => ( (*print(concat[tcName tcon, " copied as ", tcName tc, "\n"]);*) tc (* Use the entry from the cache. *) ) | NONE => (* Either a hidden identifier or alternatively this can happen as part of the matching process. When matching a structure to a signature we first match up the type constructors then copy the type of each value replacing bound type IDs with the actual IDs as part of the checking process. We will return SOME newId but we don't have a cache so return NONE for List.find. *) let val newName = mungeName(tcName tcon) in (*print(concat[tcName tcon, " not cached\n"]);*) makeTypeConstructor(newName, tcTypeVars tcon, newId, tcLocations tcon) end end ) (* Exported version. *) fun copyTypeConstr (tcon, typeMap, copyTypeVar, mungeName) = copyTypeConstrWithCache(tcon, typeMap, copyTypeVar, mungeName, []) (* Compose typeID maps. If the first map returns a Bound id we apply the second otherwise just return the result of the first. *) fun composeMaps(m1, m2) n = let fun map2 (TypeId{idKind=Bound{ offset, ...}, ...}) = m2 offset | map2 (id as TypeId{idKind=Free _, ...}) = id | map2 (TypeId{idKind=TypeFn(args, equiv), access, description, ...}) = let fun copyId(TypeId{idKind=Free _, ...}) = NONE | copyId id = SOME(map2 id) (* If it's a type function e.g. this was a "where type" we have to apply the map to any type identifiers in the type. *) val copiedEquiv = copyType(equiv, fn x => x, fn tcon => copyTypeConstr (tcon, copyId, fn x => x, fn y => y)) in TypeId{idKind = TypeFn(args, copiedEquiv), access=access, description=description} end in map2(m1 n) end (* Basic procedure to print a type structure. *) type printTypeEnv = { lookupType: string -> (typeConstrSet * (int->typeId) option) option, lookupStruct: string -> (structVals * (int->typeId) option) option} val emptyTypeEnv = { lookupType = fn _ => NONE, lookupStruct = fn _ => NONE } (* Test whether two type constructors are the same after mapping. This is used to try to find the correct "path" to a type constructor when printing. *) fun eqTypeConstrs(xTypeCons, xMap, yTypeCons, yMap) = let fun id x = x fun copyId (SOME mapTypeId) (TypeId{idKind=Bound{ offset, ...}, ...}) = SOME(mapTypeId offset) | copyId _ _ = NONE val mappedX = copyTypeConstr(xTypeCons, copyId xMap, id, id) and mappedY = copyTypeConstr(yTypeCons, copyId yMap, id, id) in equalTypeIds(tcIdentifier mappedX, tcIdentifier mappedY) end (* prints a block of items *) fun tDisp (t : types, depth : FixedInt.int, typeVarName : typeVarForm -> string, env: printTypeEnv, sigMap: (int->typeId)option) : pretty = let (* prints a block of items *) fun dispP (t : types, depth : FixedInt.int) : pretty = let (* prints a block of items *) fun parenthesise depth t = if depth <= 1 then PrettyString "..." else PrettyBlock (0, false, [], [ PrettyString "(", dispP (t, depth - 1), PrettyString ")" ]); (* prints a sequence of items *) fun prettyList [] _ _: pretty list = [] | prettyList [H] depth separator = let val v = eventual H; in if separator = "*" andalso (isFunctionType v orelse isProductType v) then (* Must bracket the expression *) [parenthesise depth v] else [dispP (v, depth)] end | prettyList (H :: T) depth separator = if depth <= 0 then [PrettyString "..."] else let val v = eventual H; in PrettyBlock (0, false, [], [(if separator = "*" andalso (isFunctionType v orelse isProductType v) then (* Must bracket the expression *) parenthesise depth v else dispP (v, depth)), PrettyBreak (if separator = "," then 0 else 1, 0), PrettyString separator ]) :: PrettyBreak (1, 0) :: prettyList T (depth - 1) separator end; val typ = eventual t; (* Find the real type structure *) in case typ of TypeVar tyVar => let val tyVal : types = tvValue tyVar; in case tyVal of EmptyType => PrettyString (typeVarName tyVar) | _ => dispP (tyVal, depth) end (* Type construction. *) | TypeConstruction {args, name, constr=typeConstructor, ...} => let val constrName = (* Use the type constructor name unless we're had an error. *) if isUndefined typeConstructor then name else tcName typeConstructor (* There are three possible cases: we may not find any type with the name, we may look up the name and find the type or we may look up the name and find a different type. *) datatype isFound = NotFound | FoundMatch | FoundNotMatch (* If we're printing a value that refers to a type constructor we want to print the correct amount of any structure prefix for the current context. *) fun findType (_, []) = NotFound | findType ({ lookupType, ... }, [typeName]) = ( (* This must be the name of a type. *) case lookupType typeName of SOME (t, map) => if eqTypeConstrs(typeConstructor, sigMap, tsConstr t, map) then FoundMatch else FoundNotMatch | NONE => NotFound ) | findType ({ lookupStruct, ... }, structName :: tail) = ( (* This must be the name of a structure. Does it contain our type? *) case lookupStruct structName of SOME(Struct { signat, ...}, map) => let val Signatures { tab, typeIdMap, ...} = signat val Env { lookupType, lookupStruct, ...} = makeEnv tab val newMap = case map of SOME map => composeMaps(typeIdMap, map) | NONE => typeIdMap fun subLookupType s = case lookupType s of NONE => NONE | SOME t => SOME(t, SOME newMap) fun subLookupStruct s = case lookupStruct s of NONE => NONE | SOME t => SOME(t, SOME newMap) in findType({lookupType=subLookupType, lookupStruct=subLookupStruct}, tail) end | NONE => NotFound ) (* See if we have this type in the current environment or in some structure in the current environment. The name we have may be a full structure path. *) fun nameToList ("", l) = (l, NotFound) (* Not there. *) | nameToList (s, l) = let val { first, second } = splitString s val currentList = second :: l in case findType(env, currentList) of FoundMatch => (currentList, FoundMatch) | FoundNotMatch => ( case nameToList(first, currentList) of result as (_, FoundMatch) => result | (l, _) => (l, FoundNotMatch) ) | NotFound => nameToList(first, currentList) end (* Try the type constructor name first. This is usually accurate. If not fall back to the type identifier. This may be needed in rarer cases. *) val names = case nameToList(constrName, []) of (names, FoundMatch) => names (* Found the type constructor name. *) | (names, f) => let (* Try the type identifier name. *) val TypeId { description = { name=idName, ...}, ...} = case (sigMap, tcIdentifier typeConstructor) of (SOME map, TypeId{idKind=Bound{offset, ...}, ...}) => map offset | (_, id) => id (* Only add "?" if we actually found a type with the required name but it wasn't the right one. This allows us to print a sensible result where the type has been shadowed but doesn't affect situations such as where we create a unique type name for a free type variable. *) fun addQuery n = case f of FoundNotMatch => "?" :: n | _ => n in if idName = "" then addQuery names else case nameToList(idName, []) of (idNames, FoundMatch) => idNames | (_, _) => addQuery names (* Print it as "?.t". This isn't ideal but will help in situations where we have redefined "t". *) end val newName = String.concatWith "." names (* Get the declaration position for the type constructor. *) val constrContext = if isUndefined typeConstructor then [] else ( case List.find(fn DeclaredAt _ => true | _ => false) (tcLocations typeConstructor) of SOME(DeclaredAt loc) => [ContextLocation loc] | _ => [] ) val constructorEntry = PrettyBlock(0, false, constrContext, [PrettyString newName(*constrName*)]) in case args of [] => constructorEntry | args as hd :: tl => let val argVal = eventual hd; in PrettyBlock (0, false, [], [ (* If we have just a single argument and it's just a type constructor or a construction we don't need to parenthesise it. *) if null tl andalso not (isProductType argVal orelse isFunctionType argVal) then dispP (argVal, depth - 1) else if depth <= 1 then PrettyString "..." else PrettyBlock(0, false, [], [PrettyString "(", PrettyBreak (0, 0)] @ prettyList args (depth - 1) "," @ [PrettyBreak (0, 0), PrettyString ")"] ), PrettyBreak(1, 0), constructorEntry (* The constructor. *) ]) end end | FunctionType {arg, result} => if depth <= 0 then PrettyString "..." else (* print out in infix notation *) let val evArg = eventual arg; in PrettyBlock (0, false, [], [ (* If the argument is a function it must be printed as (a-> b)->.. *) if isFunctionType evArg then parenthesise depth evArg else dispP (evArg, depth - 1), PrettyBreak(1, 2), PrettyString "->", PrettyBreak (1, 2), dispP (result, depth - 1) ]) end | LabelledType (r as {recList, ...}) => if depth <= 0 then PrettyString "..." else if isProductType typ then (* Print as a product *) PrettyBlock (0, false, [], (* Print them as t1 * t2 * t3 .... *) prettyList (map (fn {typeof, ...} => typeof) recList) depth "*") else (* Print as a record *) let (* The ordering on fields is designed to allow mixing of tuples and records (e.g. #1). It puts shorter names before longer so that #11 comes after #2 and before #100. For named records it does not make for easy reading so we sort those alphabetically when printing. *) val sortedRecList = Misc.quickSort(fn {name = a, ...} => fn {name = b, ...} => a <= b) recList in PrettyBlock (2, false, [], PrettyString "{" :: (let fun pRec [] _ = [] | pRec ({name, typeof} :: T) depth = if depth <= 0 then [PrettyString "..."] else [ PrettyBlock(0, false, [], [ PrettyBlock(0, false, [], [ PrettyString (name ^ ":"), PrettyBreak(1, 0), dispP(typeof, depth - 1) ] @ (if null T then [] else [PrettyBreak (0, 0), PrettyString ","]) ) ]@ (if null T then [] else PrettyBreak (1, 0) :: pRec T (depth-1)) ) ] in pRec sortedRecList (depth - 1) end) @ [ PrettyString (if recordIsFrozen r then "}" else case recList of [] => "...}" | _ => ", ...}")] ) end | OverloadSet {typeset = []} => PrettyString "no type" | OverloadSet {typeset = tconslist} => (* This typically arises when printing error messages in the second pass because the third pass will select a single type e.g. int where possible. To simplify the messages select a single type if possible. *) ( case preferredOverload tconslist of SOME tcons => dispP(mkTypeConstruction (tcName tcons, tcons,[], []), depth) | NONE => (* Just print the type constructors separated by / *) let fun constrLocation tcons = case List.find(fn DeclaredAt _ => true | _ => false) (tcLocations tcons) of SOME(DeclaredAt loc) => [ContextLocation loc] | _ => [] (* Type constructor with context. *) fun tconsItem tcons = PrettyBlock(0, false, constrLocation tcons, [PrettyString(tcName tcons)]) fun printTCcons [] = [] | printTCcons [tcons] = [tconsItem tcons] | printTCcons (tcons::rest) = tconsItem tcons :: PrettyBreak (0, 0) :: PrettyString "/" :: printTCcons rest in PrettyBlock (0, false, [], printTCcons tconslist) end ) | EmptyType => PrettyString "no type" | BadType => PrettyString "bad" end (* dispP *) in dispP (t, depth) end (* tDisp *); (* Generate unique type-variable names. *) fun varNameSequence () : typeVarForm -> string = (* We need to ensure that every distinct type variable has a distinct name. Each new type variable is given a name starting at "'a" and going on through the alphabet. *) let datatype names = Names of {name: string, entry: typeVarForm} val nameNum = ref ~1 val gNameList = ref [] (* List of names *) in (* If the type is already there return the name we have given it otherwise make a new name and put it in the list. *) fn var => case List.find (fn (Names {entry,...}) => sameTv (entry, var)) (!gNameList) of NONE => (* Not on the list - make a new name *) let fun name num = (if num >= 26 then name (num div 26 - 1) else "") ^ String.str (Char.chr (num mod 26 + Char.ord #"a")) val () = nameNum := !nameNum + 1 val n = (if tvEquality var then "''" else "'") ^ name(!nameNum) (* Should explicit type variables be distinguished? *) in gNameList := Names{name=n, entry=var} :: !gNameList; n end | SOME (Names {name,...}) => name end (* varNameSequence *) (* Print a type (as a block of items) *) fun displayWithMap (t : types, depth : FixedInt.int, env, sigMap) = tDisp (t, depth, varNameSequence (), env, sigMap) and display (t : types, depth : FixedInt.int, env) = tDisp (t, depth, varNameSequence (), env, NONE) (* Print out zero, one or more type variables (unblocked) *) fun printTypeVars([], _, _) = [] (* No type vars i.e. monotype *) | printTypeVars([oneVar], depth, typeV) = (* Single type var. *) [ tDisp (TypeVar oneVar, depth, typeV, emptyTypeEnv, NONE), PrettyBreak (1, 0) ] | printTypeVars(vars, depth, typeV) = (* Must parenthesise them. *) if depth <= 1 then [PrettyString "..."] else [ PrettyBlock(0, false, [], PrettyString "(" :: PrettyBreak(0, 0) :: (let fun pVars vars depth: pretty list = if depth <= 0 then [PrettyString "..."] else if null vars then [] else [ tDisp (TypeVar(hd vars), depth, typeV, emptyTypeEnv, NONE), PrettyBreak (0, 0) ] @ (if null (tl vars) then [] else PrettyString "," :: PrettyBreak (1, 0) :: pVars (tl vars) (depth - 1) ) in pVars vars depth end) @ [PrettyString ")"] ), PrettyBreak (1, 0) ] (* Version used in parsetree. *) fun displayTypeVariables (vars : typeVarForm list, depth : FixedInt.int) = printTypeVars (vars, depth, varNameSequence ()) (* Parse tree for types. This is used to represent types in the source. *) datatype typeParsetree = ParseTypeConstruction of { name: string, args: typeParsetree list, location: location, nameLoc: location, argLoc: location, (* foundConstructor is set to the constructor when it has been looked up. This allows us to get the location where it was declared if we export the parse-tree. *) foundConstructor: typeConstrs ref } | ParseTypeProduct of { fields: typeParsetree list, location: location } | ParseTypeFunction of { argType: typeParsetree, resultType: typeParsetree, location: location } | ParseTypeLabelled of { fields: ((string * location) * typeParsetree * location) list, frozen: bool, location: location } | ParseTypeId of { types: typeVarForm, location: location } | ParseTypeBad (* Place holder for errors. *) fun typeFromTypeParse( ParseTypeConstruction{ args, name, location, foundConstructor = ref constr, ...}) = let val argTypes = List.map typeFromTypeParse args in TypeConstruction {name = name, constr = constr, args = argTypes, locations = [DeclaredAt location]} end | typeFromTypeParse(ParseTypeProduct{ fields, ...}) = mkProductType(List.map typeFromTypeParse fields) | typeFromTypeParse(ParseTypeFunction{ argType, resultType, ...}) = mkFunctionType(typeFromTypeParse argType, typeFromTypeParse resultType) | typeFromTypeParse(ParseTypeLabelled{ fields, frozen, ...}) = let fun makeField((name, _), t, _) = mkLabelEntry(name, typeFromTypeParse t) in mkLabelled(sortLabels(List.map makeField fields), frozen) end | typeFromTypeParse(ParseTypeId{ types, ...}) = TypeVar types | typeFromTypeParse(ParseTypeBad) = BadType fun makeParseTypeConstruction((constrName, nameLoc), (args, argLoc), location) = ParseTypeConstruction{ name = constrName, nameLoc = nameLoc, args = args, argLoc = argLoc, location = location, foundConstructor = ref undefConstr } fun makeParseTypeProduct(recList, location) = ParseTypeProduct{ fields = recList, location = location } fun makeParseTypeFunction(arg, result, location) = ParseTypeFunction{ argType = arg, resultType = result, location = location } fun makeParseTypeLabelled(recList, frozen, location) = ParseTypeLabelled{ fields = recList, frozen = frozen, location = location } fun makeParseTypeId(types, location) = ParseTypeId{ types = types, location = location } fun unitTree location = ParseTypeLabelled{ fields = [], frozen = true, location = location } (* Build an export tree from the parse tree. *) fun typeExportTree(navigation, p: typeParsetree) = let val typeof = typeFromTypeParse p (* Common properties for navigation and printing. *) val commonProps = PTprint(fn d => display(typeof, d, emptyTypeEnv)) :: PTtype typeof :: exportNavigationProps navigation fun asParent () = typeExportTree(navigation, p) in case p of ParseTypeConstruction{ location, nameLoc, args, argLoc, ...} => let (* If the constructor has been bound return the declaration location. We have to attach the declaration location in the right place if this is a polytype e.g. if we have "int list" here we will have the location for "list" which is the second item not the first. *) val (name, decLoc) = case typeof of TypeConstruction { constr, name, ...} => if isUndefined constr then (name, []) else (name, mapLocationProps(tcLocations constr)) | _ => ("", []) (* Error? *) val navNameAndArgs = (* Separate cases for nullary, unary and higher type constructions. *) case args of [] => decLoc (* Singleton e.g. int *) | [oneArg] => let (* Single arg e.g. int list. *) (* Navigate between the type constructor and the argument. Since the arguments come before the constructor we go there first. *) fun getArg () = typeExportTree({parent=SOME asParent, previous=NONE, next=SOME getName}, oneArg) and getName () = getStringAsTree({parent=SOME asParent, previous=SOME getArg, next=NONE}, name, nameLoc, decLoc) in [PTfirstChild getArg] end | args => let (* Multiple arguments e.g. (int, string) pair *) fun getArgs () = (argLoc, exportList(typeExportTree, SOME getArgs) args @ exportNavigationProps{parent=SOME asParent, previous=NONE, next=SOME getName}) and getName () = getStringAsTree({parent=SOME asParent, previous=SOME getArgs, next=NONE}, name, nameLoc, decLoc) in [PTfirstChild getArgs] end in (location, navNameAndArgs @ commonProps) end | ParseTypeProduct{ location, fields, ...} => (location, exportList(typeExportTree, SOME asParent) fields @ commonProps) | ParseTypeFunction{ location, argType, resultType, ...} => (location, exportList(typeExportTree, SOME asParent) [argType, resultType] @ commonProps) | ParseTypeLabelled{ location, fields, ...} => let fun exportField(navigation, label as ((name, nameLoc), t, fullLoc)) = let (* The first position is the label, the second the type *) fun asParent () = exportField (navigation, label) fun getLab () = getStringAsTree({parent=SOME asParent, next=SOME getType, previous=NONE}, name, nameLoc, [PTtype(typeFromTypeParse t)]) and getType () = typeExportTree({parent=SOME asParent, previous=SOME getLab, next=NONE}, t) in (fullLoc, PTfirstChild getLab :: exportNavigationProps navigation) end in (location, exportList(exportField, SOME asParent) fields @ commonProps) end | ParseTypeId{ location, ...} => (location, commonProps) | ParseTypeBad => (nullLocation, commonProps) end fun displayTypeParse(types, depth, env) = display(typeFromTypeParse types, depth, env) (* Associates type constructors from the environment with type identifiers (NOT type variables) *) fun assignTypes (tp : typeParsetree, lookupType : string * location -> typeConstrSet, lex : lexan) = let fun typeFromTypeParse(ParseTypeConstruction{ args, name, location, foundConstructor, ...}) = let (* Assign constructor, then the parameters. *) val TypeConstrSet(constructor, _) = lookupType (name, location) val () = (* Check that it has the correct arity. *) if not (isUndefined constructor) then let val arity : int = tcArity constructor; val num : int = length args; in if arity <> num then (* Give an error message *) errorMessage (lex, location, String.concat["Type constructor (", tcName constructor, ") requires ", Int.toString arity, " type(s) not ", Int.toString num]) else foundConstructor := constructor end else () val argTypes = List.map typeFromTypeParse args in TypeConstruction {name = name, constr = constructor, args = argTypes, locations = [DeclaredAt location]} end | typeFromTypeParse(ParseTypeProduct{ fields, ...}) = mkProductType(List.map typeFromTypeParse fields) | typeFromTypeParse(ParseTypeFunction{ argType, resultType, ...}) = mkFunctionType(typeFromTypeParse argType, typeFromTypeParse resultType) | typeFromTypeParse(ParseTypeLabelled{ fields, frozen, ...}) = let fun makeField((name, _), t, _) = mkLabelEntry(name, typeFromTypeParse t) in mkLabelled(sortLabels(List.map makeField fields), frozen) end | typeFromTypeParse(ParseTypeId{ types, ...}) = TypeVar types | typeFromTypeParse(ParseTypeBad) = BadType in typeFromTypeParse tp end; (* When we have finished processing a list of patterns we need to check that the record is now frozen. *) fun recordNotFrozen (TypeVar t) : bool = (* Follow the chain *) recordNotFrozen (tvValue t) | recordNotFrozen (LabelledType r) = not(recordIsFrozen r) | recordNotFrozen _ = false (* record or type alias *); datatype generalMatch = Matched of {old: typeVarForm, new: types}; fun generaliseTypes (atyp : types, checkTv: typeVarForm->types option) = let val madeList = ref [] (* List of tyVars. *); fun tvs atyp = let val tyVar = typesTypeVar atyp; in case List.find(fn Matched{old, ...} => sameTv (old, tyVar)) (!madeList) of SOME(Matched{new, ...}) => new | NONE => ( case checkTv tyVar of SOME found => found | NONE => let (* Not on the list - make a new name *) (* Make a unifiable type variable even if the original is nonunifiable. *) val n : types = mkTypeVar (generalisable, tvEquality tyVar, false, tvPrintity tyVar) in (* Set the new variable to have the same value as the existing. That is only really needed if we have an overload set. *) tvSetValue (typesTypeVar n, tvValue tyVar); madeList := Matched {old = tyVar, new = n} :: !madeList; n end ) end fun copyTypeVar (atyp as TypeVar tyVar) = if tvLevel tyVar <> generalisable then atyp (* Not generalisable. *) else (* Unbound, overload set or flexible record *) let val newTv = tvs atyp in (* If we have a type variable pointing to a flexible record we have to copy the type pointed at by the variable. *) case tvValue tyVar of valu as LabelledType _ => tvSetValue (typesTypeVar newTv, copyType (valu, copyTypeVar, fn t => t)) | _ => (); newTv end | copyTypeVar atyp = atyp val copied = (* Only process type variables. Return type constructors unchanged. *) copyType (atyp, copyTypeVar, fn t => t (*copyTCons*)) in (copied, ! madeList) end (* generaliseTypes *); (* Exported wrapper for generaliseTypes. *) fun generalise atyp = let val (t, newMatch) = generaliseTypes (atyp, fn _ => NONE) fun makeResult(Matched{new, old}) = {value=new, equality=tvEquality old, printity=tvPrintity old} in (t, List.map makeResult newMatch) end; (* Return the original polymorphic type variables. *) fun getPolyTypeVars(atyp, map) = let val (_, newMatch) = generaliseTypes (atyp, map) in List.map (fn(Matched{old, ...}) => old) newMatch end; fun generaliseWithMap(atyp, map) = let val (t, newMatch) = generaliseTypes (atyp, map) fun makeResult(Matched{new, old}) = {value=new, equality=tvEquality old, printity=tvPrintity old} in (t, List.map makeResult newMatch) end (* Find the argument type which gives this result when the constructor is applied. If we have, for example, a value of type int list and we have discovered that this is a "::" node we have to work back by comparing the type of "::" ('a * 'a list -> 'a list) to find the argument of the constructor (int * int list) and hence how to print it. (Actually "list" is treated specially). *) fun constructorResult (FunctionType{arg, result=TypeConstruction{args, ...}}, typeArgs) = let val matches = ListPair.zip(List.map typesTypeVar args, typeArgs) fun getArg tv = case List.find(fn (atv, _) => sameTv(tv, atv)) matches of SOME (_, ty) => SOME ty | NONE => NONE in #1 (generaliseTypes(arg, getArg)) end | constructorResult _ = raise InternalError "Not a function type" (* If we have a type construction which is an alias for another type we construct the alias by first instantiating all the type variables and then copying the type. *) fun makeEquivalent (atyp, args) = case tcIdentifier atyp of TypeId{idKind=TypeFn(typeArgs, typeResult), ...} => let val matches = ListPair.zip(typeArgs, args) fun getArg tv = case List.find(fn (atv, _) => sameTv(tv, atv)) matches of SOME (_, ty) => SOME ty | NONE => NONE in #1 (generaliseTypes(typeResult, getArg)) end | TypeId _ => raise InternalError "makeEquivalent: Not a type function" (* Look for the occurrence of locally declared datatypes in the type of a value. *) fun checkForEscapingDatatypes(ty: types, errorFn: string->unit) : unit = let fun checkTypes (typ: types) (ok: bool) : bool = case typ of TypeConstruction {constr, args, ...} => if tcIsAbbreviation constr then (* May be an alias for a type that contains a local datatype. *) foldType checkTypes (makeEquivalent (constr, args)) ok else if ok then ( case tcIdentifier constr of TypeId{access=Local{addr, ...}, ...} => if !addr < 0 then ( errorFn("Type of expression contains local datatype (" ^ tcName constr ^") outside its definition."); false ) else true | _ => true (* Could we have a "selected" entry with a local datatype? *) ) else false | _ => ok in foldType checkTypes ty true; () end (* This 3-valued logic is used because in a few cases we may not be sure if equality testing is allowed. If we have 2 mutually recursive datatypes t = x of s | ... and s = z of t we would first examine "t", find that it uses "s", look at "s", find that refers back to "t". To avoid infinite recursion we return the result that equality "maybe" allowed for "t" and hence for "s". However we may find that the other constructors for "t" do not allow equality and so equality will not be allowed for "s" either. *) datatype tri = Yes (* 3-valued logic *) | No | Maybe; (* Returns a flag saying if equality testing is allowed for values of the given type. "equality" is used both to generate the code for a specific call of equality e.g. (a, b, c) = f(x), and to generate the equality operation for a type when it is declared. In the latter case type variables may be parameters which will be filled in later e.g. type 'a list = nil | op :: of ('a * 'a list). "search" is a function which looks up constructors in mutually recursive type declarations. "lookupTypeVar" deals with type variables. If they represent parameters to a type declaration equality checking will be allowed. If we are unifying this type to an equality type variable they will be unified to new equality type variables. Otherwise equality is not allowed. *) fun equality (ty, search, lookupTypeVar) : tri = let (* Can't use foldT because it is not monotonic (equality on ref 'a is allowed). *) (* Returns Yes only if equality testing is allowed for all types in the list. *) fun eqForList ([], soFar) = soFar | eqForList (x::xs, soFar) = case equality (x, search, lookupTypeVar) of No => No | Maybe => eqForList (xs, Maybe) | Yes => eqForList (xs, soFar); in case eventual ty of TypeVar tyVar => (* The type variable may point to a flexible record or an overload set or it may be the end of the chain. If this is a labelled record we have to make sure that any fields we add also admit equality. lookupTypeVar makes the type variable an equality type so that any new fields are checked for equality but we also have to call "equality" to check the existing fields. *) if tvEquality tyVar then Yes else ( case tvValue tyVar of lab as LabelledType _ => ( case lookupTypeVar tyVar of No => No | _ => equality (lab, search, lookupTypeVar) ) | _ => lookupTypeVar tyVar ) | FunctionType {...} => No (* No equality on function types! *) | TypeConstruction {constr, args, ...} => if isUndefined constr then No else if tcIsAbbreviation constr then (* May be an alias for a type that allows equality. *) equality (makeEquivalent (constr, args), search, lookupTypeVar) (* ref - Equality is permitted on refs of all types *) (* The Definition of Standard ML says that ref is the ONLY type constructor which is treated in this way. The standard basis library says that other mutable types such as array should also work this way. *) else if isPointerEqType(tcIdentifier constr) then Yes (* Others apart from ref and real *) else if tcEquality constr (* Equality allowed. *) then eqForList (args, Yes) (* Must be allowed for all the args *) else let (* Not an alias. - Look it up. *) val s = search (tcIdentifier constr); in if s = No then No else eqForList (args, s) end (* TypeConstruction *) | LabelledType {recList, ...} => (* Record equality if all subtypes are (ignore frozen!) *) (* TODO: Avoid copying the list? *) eqForList (map (fn{typeof, ...}=>typeof) recList, Yes) | OverloadSet _ => (* This should not happen because all overload sets should be pointed to by type variables and so should be handled in the TypeVar case. *) raise InternalError "equality - Overloadset found" | BadType => No | EmptyType => No (* shouldn't occur *) end (* When a datatype is declared we test to see if equality is allowed. The types are mutually recursive so value constructors of one type may take arguments involving values of any of the others. *) fun computeDatatypeEqualities(types: typeConstrSet list, boundIdEq) = let datatype state = Processed of tri (* Already processed or processing. *) | NotSeen of typeConstrSet list (* Value is list of constrs. *); (* This table tells us, for each type constructor, whether it definitely admits equality, definitely does not or whether we have yet to look at it. *) fun isProcessed (Processed _) = true | isProcessed _ = false; fun stateProcessed (Processed x) = x | stateProcessed _ = raise Match; fun stateNotSeen (NotSeen x) = x | stateNotSeen _ = raise Match; val {enter:typeId * state -> unit,lookup} = mapTable sameTypeId; (* Look at each of the constructors in the list. Equality testing is only allowed if it is allowed for each of the alternatives. *) fun constrEq _ [] soFar = soFar (* end of list - all o.k. *) | constrEq constructor (h :: t) soFar = (* The constructor may be a constant e.g. datatype 'a list = nil | ... or a function e.g. datatype 'a list = ... cons of 'a * 'a list. *) if not (isFunctionType (valTypeOf h)) (* Constant *) then constrEq constructor t soFar (* Go on to the next. *) else let (* Function - look at the argument type. *) (* Equality is allowed for any type-variable. The only type variables allowed are parameters to the datatype so if we have a type variable then equality is allowed for this datatype. *) val eq = equality (#arg (typesFunctionType (valTypeOf h)), genEquality, fn _ => Yes); in if eq = No then (* Not allowed. *) No else (* O.k. - go on to the next. *) constrEq constructor t (if eq = Maybe then Maybe else soFar) end (* constrEq *) (* This procedure checks to see if equality is allowed for this datatype. *) and genEquality constructorId = let (* Look it up to see if we have already done it. It may fail because we may have constructors that do not admit equality. *) val thisState = case (lookup constructorId, constructorId) of (SOME inList, _) => inList | (NONE, TypeId{idKind = Bound{offset, ...}, ...}) => Processed(if boundIdEq offset then Yes else No) | _ => Processed No in if isProcessed thisState then stateProcessed thisState (* Have either done it already or are currently doing it. *) else (* notSeen - look at it now. *) let (* Equality is allowed for this datatype only if all of them admit it. There are various other alternatives but this is what the standard says. If the "name" is rigid (free) we must not grant equality if it is not already there although that is not an error. *) (* Set the state to "Maybe". This prevents infinite recursion. *) val () = enter (constructorId, Processed Maybe); val eq = List.foldl (fn (cons, t) => if t = No then No else constrEq cons (tsConstructors cons) t) Yes (stateNotSeen thisState); in (* Set the state we have found if it is "yes" or "no". If it is maybe we have a recursive reference which appears to admit equality, but may not. E.g. if we have datatype t = A of s | B of int->int and s = C of t if we start processing "t" we will go on to "s" and do that before returning to "t". It is only later we find that "t" does not admit equality. If we get "Maybe" as the final result when all the recursion has been unwound we can set the result to "yes", but any intermediate "Maybe"s have to be done again. *) enter (constructorId, if eq = Maybe then thisState else Processed eq); eq end end (* genEquality *); in (* If we have an eqtype we set it to true, otherwise we set all of them to "notSeen" with the constructor as value. *) List.app (fn dec as TypeConstrSet(decCons, _) => let (* If we have two datatypes which share we may already have one in the table. We have to link them together. *) val tclist = case lookup (tcIdentifier decCons) of NONE => [dec] | SOME l => let val others = stateNotSeen l val newList = dec :: others; in (* If any of these are already equality types (i.e. share with an eqtype) then they all must be. *) if tcEquality decCons orelse tcEquality (tsConstr(hd others)) then List.app (fn d => tcSetEquality (tsConstr d, true)) newList else (); newList end in enter (tcIdentifier decCons, NotSeen tclist) end) types; (* Apply genEquality to each element of the list. *) List.app (fn TypeConstrSet(constructor, _) => let val constructorId = tcIdentifier constructor; val eqForCons = genEquality constructorId; in (* If the result is "Maybe" it involves a recursive reference, but the rest of the type allows equality. The type admits equality. *) if eqForCons = No then () (* Equality not allowed *) else ( (* Turn on equality. *) enter (constructorId, Processed Yes); tcSetEquality (constructor, true) ) end) types end (* computeDatatypeEqualities *); datatype matchResult = SimpleError of types * types * string | TypeConstructorError of types * types * typeConstrs * typeConstrs (* Type matching algorithm for both unification and signature matching. *) (* The mapping has now been moved out of here. Instead when signature matching the target signature is copied before this is called which means that this process is now symmetric. There may be some redundant tests left in here. *) fun unifyTypes(Atype : types, Btype : types) : matchResult option = let (* Get the result in here. This isn't very ML-like but it greatly simplifies converting the code. *) val matchResult: matchResult option ref = ref NONE fun matchError error = (* Only report one error. *) case matchResult of ref (SOME _) => () | r => r := SOME error fun cantMatch(alpha, beta, text) = matchError(SimpleError(alpha, beta, text)) fun match (Atype : types, Btype : types) : unit = let (* Check two records/tuples and return the combined type. *) fun unifyRecords (rA as {recList=typAlist, fullList = gA}, rB as {recList=typBlist, fullList = gB}, typA : types, typB : types) : types = let val typAFrozen = recordIsFrozen rA and typBFrozen = recordIsFrozen rB fun matchLabelled ([], []) = [] (* Something left in bList - this is fine if typeA is not frozen. e.g. (a: s, b: t) will match (a: s, ...) but not just (a:s). *) | matchLabelled ([], bList as {name=bName, ...} :: _) = ( if typAFrozen then cantMatch (typA, typB, "(Field " ^ bName ^ " missing)") else (); bList (* return the remainder of the list *) ) | matchLabelled (aList as {name=aName, ...} :: _, []) = (* Something left in bList *) ( if typBFrozen then cantMatch (typA, typB, "(Field " ^ aName ^ " missing)") else (); aList (* the rest of aList *) ) | matchLabelled (aList as ((aVal as {name=aName,typeof=aType})::aRest), bList as ((bVal as {name=bName,typeof=bType})::bRest)) = (* both not nil - look at the names. *) let val order = compareLabels (aName, bName); in if order = 0 (* equal *) then (* same name - must be unifiable types *) ( (* The result is (either) one of these with the rest of the list. *) match (aType, bType); aVal :: matchLabelled (aRest, bRest) ) else if order < 0 (* aName < bName *) then (* The entries in each list are in order so this means that this entry is not in bList. If the typeB is frozen this is an error. *) if typBFrozen (* Continue with the entry removed. *) then (cantMatch (typA, typB, "(Field " ^ aName ^ " missing)"); aList) else aVal :: matchLabelled (aRest, bList) else (* aName > bName *) if typAFrozen then (cantMatch (typA, typB, "(Field " ^ bName ^ " missing)"); bList) else bVal :: matchLabelled (aList, bRest) end (* not nil *); (* Return the combined list. Only actually used if both are flexible. *) val result = if typAFrozen andalso typBFrozen andalso List.length typAlist <> List.length typBlist then (* Don't attempt to unify the fields if we have the wrong number of items. If we've added or removed an item from a tuple e.g. a function with multiple arguments, it's more useful to know this than to get unification errors on fields that don't match. *) (cantMatch (typA, typB, "(Different number of fields)"); []) else matchLabelled (typAlist, typBlist) fun lastFlex(FlexibleList(ref(r as FlexibleList _))) = lastFlex r | lastFlex(FlexibleList r) = SOME r | lastFlex(FieldList _) = NONE in if typAFrozen then (if typBFrozen then () else valOf(lastFlex gB) := gA; typA) else if typBFrozen then (valOf(lastFlex gA) := gB; typB) else let (* We may have these linked already in which case we shouldn't do anything. *) val lastA = valOf(lastFlex gA) and lastB = valOf(lastFlex gB) in if lastA = lastB then () else let val genericFields = FieldList(map #name result, false) in (* If these are both flexible we have link all the generics together so that if we freeze any one of them they all get frozen. *) lastA := genericFields; lastB := FlexibleList lastA end; LabelledType {recList = result, fullList = gA} end end (* unifyRecords *); (* Sets a type variable to a value. - Checks that the type variable we are assigning does not occur in the expression we are about to assign to it. Such cases can occur if we have infinitely-typed expressions such as fun a. a::a where a has type 'a list list ... Also propagates the level information of the type variable. Now also deals with flexible records. *) fun assign (var, t) = let (* Mapped over the type to be assigned. *) (* Returns "false" if it is safe to make the assignment. Sorts out imperative type variables and propagates level information. N.B. It does not propagate equality status. The reason is that if we are unifying ''a with 'b ref, the 'b does NOT become an equality type var. In all other cases it would. *) fun occursCheckFails _ true = true | occursCheckFails ty false = let val t = eventual ty in case t of TypeVar tvar => let (* The level is the minimum of the two, and if we are unifying with an equality type variable we must make this into one. *) val minLev = Int.min (tvLevel var, tvLevel tvar) val oldValue = tvValue tvar in if tvLevel tvar <> minLev then (* If it is nonunifiable we cannot make its level larger. *) if tvNonUnifiable tvar then cantMatch (Atype, Btype, "(Type variable is free in surrounding scope)") else let (* Must make a new type var with the right properties *) (* This type variable may be a flexible record, in which case we have to save the record and put it on the new type variable. We have to do this for the record itself so that new fields inherit the correct status and also for any existing fields. *) val newTv = mkTypeVar (minLev, tvEquality tvar, false, tvPrintity tvar) in tvSetValue (typesTypeVar newTv, oldValue); tvSetValue (tvar, newTv) end else (); (* Safe if vars are different but we also have to check any flexible records. *) occursCheckFails oldValue (sameTv (tvar, var)) end | TypeConstruction {args, constr, ...} => (* If this is a type abbreviation we have to expand this before processing any arguments. We mustn't process arguments that are not actually used. *) if tcIsAbbreviation constr then occursCheckFails(makeEquivalent (constr, args)) false else List.foldr (fn (t, v) => occursCheckFails t v) false args | FunctionType {arg, result} => occursCheckFails arg false orelse occursCheckFails result false | LabelledType {recList,...} => List.foldr (fn ({ typeof, ... }, v) => occursCheckFails typeof v) false recList | _ => false end val varVal = tvValue var (* Current value of the variable to be set. *) local (* We need to process any type abbreviations before applying the occurs check. The type we're assigning could boil down to the same type variable we're trying to assign. This doesn't breach the occurs check. *) fun followVarsAndTypeFunctions t = case eventual t of ev as TypeConstruction{constr, args, ...} => if tcIsAbbreviation constr then followVarsAndTypeFunctions(makeEquivalent (constr, args)) else ev | ev => ev in val finalType = followVarsAndTypeFunctions t end (* We may actually have the same type variable after any type abbreviations have been followed. *) val reallyTheSame = case finalType of TypeVar tv => sameTv (tv, var) | _ => false in (* start of "assign" *) case varVal of LabelledType _ => (* Flexible record. Check that the records are compatible. *) match (varVal, t) | OverloadSet _ => (* OverloadSet. Check that the sets match. This is only in the case where t is something other than an overload set since we remove the overload set from a variable when unifying two sets. *) match (varVal, t) | _ => (); if reallyTheSame then () (* Don't apply the occurs check or check for non-unifiable. *) (* If this type variable was put in explicitly then it can't be assigned to something else. (We have already checked for the type variables being the same). *) else if tvNonUnifiable var then cantMatch (Atype, Btype, "(Cannot unify with explicit type variable)") else if occursCheckFails finalType false then cantMatch (Atype, Btype, "(Type variable to be unified occurs in type)") else let (* Occurs check succeeded. *) fun canMkEqTv (tvar : typeVarForm) : tri = (* Turn it into an equality type var. *) if tvEquality tvar then Yes (* If it is nonunifiable we cannot make it into an equality type var. *) else if tvNonUnifiable tvar then No else (* Must make a new type var with the right properties *) let (* This type variable may be a flexible record or an overload set, in which case we have to save the record and put it on the new type variable. We have to do both because we have to ensure that the existing fields in the flexible record admit equality and ALSO that any additional fields we may add by unification with other records also admit equality. *) val newTv = mkTypeVar (tvLevel tvar, true, false, tvPrintity tvar) val oldValue = tvValue tvar in tvSetValue (tvar, newTv); (* If this is an overloaded type we must remove any types that don't admit equality. *) case oldValue of OverloadSet{typeset} => let (* Remove any types which do not admit equality. *) fun filter [] = [] | filter (h::t) = if tcEquality h then h :: filter t else filter t in case filter typeset of [] => No | [constr] => ( (* Turn a singleton into a type construction. *) tvSetValue (typesTypeVar newTv, mkTypeConstruction(tcName constr, constr, nil, [])); Yes ) | newset => ( tvSetValue (typesTypeVar newTv, OverloadSet{typeset=newset}); Yes ) end | _ => (* Labelled record or unbound variable. *) ( tvSetValue (typesTypeVar newTv, oldValue); Yes ) end in (* If we are unifying a type with an equality type variable we must ensure that equality is allowed for that type. This will turn most type variables into equality type vars. *) if tvEquality var andalso equality (t, fn _ => No, canMkEqTv) = No then cantMatch (Atype, Btype, "(Requires equality type)") (* TODO: This can result in an unhelpful message if var is bound to a flexible record since there is no indication in the printed type that the flexible record is an equality type. It would be improved if we set the value to be EmptyType. At least then the type variable would be printed which would be an equality type. --- Adding the "Requires equality type" should improve things. *) else (); (* Propagate the "printity" status. This is probably not complete but doesn't matter too much since this is a Poly extension. *) if tvPrintity var then let fun makePrintity(TypeVar tv) _ = ( if tvPrintity tv then () else case tvValue tv of (* If it's an overload set we don't need to do anything. This will eventually be a monotype. *) OverloadSet _ => () | oldValue => let (* Labelled record or unbound variable. *) val newTv = mkTypeVar (tvLevel tv, tvEquality tv, tvNonUnifiable tv, true) in tvSetValue(tv, newTv); (* Put this on the chain if it's a labelled record. *) tvSetValue (typesTypeVar newTv, oldValue) end ) | makePrintity _ _ = () in foldType makePrintity t () end else (); (* Actually make the assignment. It doesn't matter if var is a labelled record, because t will be either a fixed record or a combination of the fields of var and t. Likewise if var was previously an overload set this may replace the set by a single type construction. *) (* If we have had an error don't make the assignment. At the very least it could prevent us producing useful error information and it could also result in unnecessary consequential errors. *) case !matchResult of NONE => tvSetValue (var, t) | SOME _ => () end end (* assign *); (* First find see if typeA and typeB are unified to anything already, and get the end of a list of "flexibles". *) val tA = eventual Atype and tB = eventual Btype in (* start of "match" *) if isUndefinedType tA orelse isUndefinedType tB then () (* If either of these was an undefined type constructor don't try to match. TODO: There are further tests below for this which are now redundant. *) else case (tA, tB) of (BadType, _) => () (* If either is an error don't try to match *) | (_, BadType) => () | (TypeVar typeAVar, TypeVar typeBVar) => (* Unbound type variable, flexible record or overload set. *) let (* Even if this is a one-way match we can allow type variables in the typeA to be instantiated to anything in the typeB. *) val typeAVal = tvValue typeAVar; (* We have two unbound type variables or flex. records. *) in if sameTv (typeAVar, typeBVar) (* same type variable? *) then () else (* no - assign one to the other *) if tvNonUnifiable typeAVar (* If we have a nonunifiable type variable we want to assign the typeB to it. If the typeB is nonunifiable as well we will get an error message. *) then assign (typeBVar, tA) else let (* If they are both flexible records we first set the typeB to the union of the records, and then set the typeA to that. In that way we propagate properties such as equality and level between the two variables. *) val typBVal = tvValue typeBVar in case (typeAVal, typBVal) of (LabelledType recA, LabelledType recB) => ( (* Turn these back into simple type variables to save checking the combined record against the originals when we make the assignment. (Would be safe but redundant). *) tvSetValue (typeBVar, emptyType); tvSetValue (typeAVar, emptyType); assign (typeBVar, unifyRecords (recA, recB, typeAVal, typBVal)); assign (typeAVar, tB) ) | (OverloadSet{typeset=setA}, OverloadSet{typeset=setB}) => let (* The lists aren't ordered so we just have to go through by hand. *) fun intersect(_, []) = [] | intersect(a, H::T) = if isInSet(H, a) then H::intersect(a, T) else intersect(a, T) val newSet = intersect(setA, setB) in case newSet of [] => cantMatch (Atype, Btype, "(Incompatible overloadings)") | _ => ( tvSetValue (typeBVar, emptyType); tvSetValue (typeAVar, emptyType); (* I've changed this from OverloadSet{typeset=newset} to use mkOverloadSet. The main reason was that it fixed a bug which resulted from a violation of the assumption that "equality" would not be passed an overload set except when pointed to by a type variable. It also removed the need for a separate test for singleton sets since mkOverloadSet deals with them. DCJM 1/9/00. *) assign (typeBVar, mkOverloadSet newSet); assign (typeAVar, tB) ) end | (EmptyType, _) => (* A is not a record or an overload set. *) assign (typeAVar, tB) | (_, EmptyType) => (* A is a record but B isn't *) assign (typeBVar, tA) (* typeB is ordinary type var. *) | _ => (* Bad combination of labelled record and overload set *) cantMatch (Atype, Btype, "(Incompatible types)") end end | (TypeVar typeAVar, _) => (* typeB is not a type variable so set typeA to typeB.*) (* Be careful if this is a non-unifiable type variable being matched to the special case of the identity type-construction. *) ( if tvNonUnifiable typeAVar orelse (case tvValue typeAVar of OverloadSet _ => true | _ => false) then ( case tB of TypeConstruction {constr, args, ...} => if isUndefined constr orelse not (tcIsAbbreviation constr) then ( case tB of TypeConstruction {constr, args, ...} => if isUndefined constr orelse not (tcIsAbbreviation constr) then assign (typeAVar, tB) else match(tA, eventual (makeEquivalent (constr, args))) | _ => assign (typeAVar, tB) ) else match(tA, eventual (makeEquivalent (constr, args))) | _ => assign (typeAVar, tB) ) else assign (typeAVar, tB) ) | (_, TypeVar typeBVar) => (* and typeA is not *) ( (* We have to check for the special case of the identity type-construction. *) if tvNonUnifiable typeBVar orelse (case tvValue typeBVar of OverloadSet _ => true | _ => false) then ( case tA of TypeConstruction {constr, args, ...} => if isUndefined constr orelse not (tcIsAbbreviation constr) then ( case tB of TypeVar tv => (* This will fail if we are matching a signature because the typeB will be non-unifiable. *) assign (tv, tA) (* set typeB to typeA *) | typB => match (tA, typB) ) else match(eventual (makeEquivalent (constr, args)), tB) | _ => ( case tB of TypeVar tv => (* This will fail if we are matching a signature because the typeB will be non-unifiable. *) assign (tv, tA) (* set typeB to typeA *) | typB => match (tA, typB) ) ) else ( case tB of TypeVar tv => (* This will fail if we are matching a signature because the typeB will be non-unifiable. *) assign (tv, tA) (* set typeB to typeA *) | typB => match (tA, typB) ) ) | (TypeConstruction({constr = tACons, args=tAargs, ...}), TypeConstruction ({constr = tBCons, args=tBargs, ...})) => ( (* We may have a number of possibilities here. a) If tA is an alias we simply expand it out and recurse (even if tB is the same alias). e.g. if we have string t where type 'a t = int*'a we expand string t into int*string and try to unify that. b) map it and see if the result is an alias. -- NOW REMOVED c) If tB is a type construction and it is an alias we expand that e.g. unifying "int list" and "int t" where type 'a t = 'a list (particularly common in signature/structure matching.) d) Finally we try to unify the stamps and the arguments. *) if isUndefined tACons orelse isUndefined tBCons then () (* If we've had an undefined type constructor don't try to check further. *) else if tcIsAbbreviation tACons (* Candidate is an alias - expand it. *) then match (makeEquivalent (tACons, tAargs), tB) else if tcIsAbbreviation tBCons then match (tA, makeEquivalent (tBCons, tBargs)) else if tcIsAbbreviation tBCons (* If the typeB is an alias it must be expanded. *) then match (tA, makeEquivalent (tBCons, tBargs)) else if sameTypeId (tcIdentifier tACons, tcIdentifier tBCons) then let (* Same type constructor - do the arguments match? *) fun matchLists [] [] = () | matchLists (a::al) (b::bl) = ( match (a, b); matchLists al bl ) | matchLists _ _ = (* This should only happen as a result of a different error. *) cantMatch (Atype, Btype, "(Different numbers of arguments)") in matchLists tAargs tBargs end (* When we have different type constructors, especially two with the same name, we try to produce more information. *) else matchError(TypeConstructorError(tA, tB, tACons, tBCons)) ) | (OverloadSet {typeset}, TypeConstruction {constr=tBCons, args=tBargs, ...}) => (* The candidate is an overloaded type and the target is a type construction. *) ( if not (isUndefined tBCons orelse not (tcIsAbbreviation tBCons)) then match (tA, makeEquivalent (tBCons, tBargs)) else if isUndefined tBCons then () else if tcIsAbbreviation tBCons then match (tA, makeEquivalent (tBCons, tBargs)) else (* See if the target type is among those in the overload set. *) if null tBargs (* Must be a nullary type constructor. *) andalso isInSet(tBCons, typeset) then () (* ok. *) (* Overload sets arise primarily with literals such as "1" and it's most likely that the error is a mismatch between int and another type rather than that the user assumed that the literal was overloaded on a type it actually wasn't. *) else case preferredOverload typeset of NONE => cantMatch (tA, tB, "(Different type constructors)") | SOME prefType => matchError( TypeConstructorError( mkTypeConstruction (tcName prefType, prefType,[], []), tB, prefType, tBCons)) ) | (TypeConstruction {constr=tACons, args=tAargs, ...}, OverloadSet {typeset}) => ( if not (isUndefined tACons orelse not (tcIsAbbreviation tACons)) then match (makeEquivalent (tACons, tAargs), tB) (* We should never find an overload set as the target for a signature match but it is perfectly possible for tB to be an overload set when unifying two types. *) else if null tAargs andalso isInSet(tACons, typeset) then () (* ok. *) else case preferredOverload typeset of NONE => cantMatch (tA, tB, "(Different type constructors)") | SOME prefType => matchError( TypeConstructorError( tA, mkTypeConstruction (tcName prefType, prefType,[], []), tACons, prefType)) ) | (OverloadSet _ , OverloadSet _) => raise InternalError "Unification: OverloadSet/OverloadSet" (* (OverloadSet , OverloadSet) should not occur because that should be handled in the (TypeVar, TypeVar) case. *) | (TypeConstruction({constr = tACons, args=tAargs, ...}), _) => if not (isUndefined tACons orelse not (tcIsAbbreviation tACons)) (* Candidate is an alias - expand it. *) then match (makeEquivalent (tACons, tAargs), tB) else (* typB not a construction (but typeA is) *) cantMatch (tA, tB, "(Incompatible types)") | (_, TypeConstruction {constr=tBCons, args=tBargs, ...}) => (* and typeA is not. *) (* May have a type equivalence e.g. "string t" matches int*string if type 'a t = int * 'a . Alternatively we may be matching a structure to a signature where the signature says "type t" and the structure contains "type t = int->int" (say). We need to set the type in the signature to int->int. *) if not (isUndefined tBCons orelse not (tcIsAbbreviation tBCons)) then match (tA, makeEquivalent (tBCons, tBargs)) else if isUndefined tBCons then () else if tcIsAbbreviation tBCons then match (tA, makeEquivalent (tBCons, tBargs)) else cantMatch (tB, tA, "(Incompatible types)") | (FunctionType {arg=typAarg, result=typAres, ...}, FunctionType {arg=typBarg, result=typBres, ...}) => ( (* must be unifiable functions *) (* In principle it doesn't matter whether we unify arguments or results first but it could affect the error messages. Is this the best way to do it? *) match (typAarg, typBarg); match (typAres, typBres) ) | (EmptyType, EmptyType) => () (* This occurs only with exceptions - empty means no argument *) | (LabelledType recA, LabelledType recB) => (* Unify the records, but discard the result because at least one of the records is frozen. *) (unifyRecords (recA, recB, tA, tB); ()) | _ => cantMatch (tA, tB, "(Incompatible types)") end (* match *) in match (Atype, Btype); ! matchResult end (* unifyTypes *) (* Turn a result from matchTypes into a pretty structure so that it can be included in a message. *) fun unifyTypesErrorReport (_, alphaTypeEnv, betaTypeEnv, what) = let fun reportError(SimpleError(alpha: types, beta: types, reason)) = (* This previously used a single type variable sequence for both types. It may be that this is needed to make sensible error messages. *) PrettyBlock(3, false, [], [ PrettyString ("Can't " ^ what (* "match" if a signature, "unify" if core lang. *)), PrettyBreak (1, 0), display (alpha, 1000 (* As deep as necessary *), alphaTypeEnv), PrettyBreak (1, 0), PrettyString "to", PrettyBreak (1, 0), display (beta, 1000 (* As deep as necessary *), betaTypeEnv), PrettyBreak (1, 0), PrettyString reason ]) | reportError(TypeConstructorError(alpha: types, beta: types, alphaCons, betaCons)) = let fun expandedTypeConstr(ty, tyEnv, tyCons) = let fun lastPart name = #second(splitString name) (* Print the type which includes the type constructor name with as much additional information as we can. *) fun printWithDesc{ location, name, description } = PrettyBlock(3, false, [], [ display (ty, 1000, tyEnv) ] @ (if lastPart name = lastPart(tcName tyCons) then [] else [ PrettyBreak(1, 0), PrettyString "=", PrettyBreak(1, 0), PrettyBlock(0, false, [ContextLocation location], [PrettyString name]) ] ) @ (if description = "" then [] else [ PrettyBreak(1, 0), PrettyBlock(0, false, [ContextLocation location], [PrettyString ("(*" ^ description ^ "*)")]) ] ) ) in case tcIdentifier tyCons of TypeId { description, ...} => printWithDesc description end in PrettyBlock(3, false, [], [ PrettyString ("Can't " ^ what (* "match" if a signature, "unify" if core lang. *)), PrettyBreak (1, 0), expandedTypeConstr(alpha, alphaTypeEnv, alphaCons), PrettyBreak (1, 0), PrettyString (if what = "unify" then "with" else "to"), PrettyBreak (1, 0), expandedTypeConstr(beta, betaTypeEnv, betaCons), PrettyBreak (1, 0), PrettyString "(Different type constructors)" ]) end in reportError end (* Given a function type returns the first argument if the function takes a tuple otherwise returns the only argument. Extended to include the case where the argument is not a function in order to work properly for overloaded literals. *) fun firstArg(FunctionType{arg= LabelledType { recList = {typeof, ...} ::_, ...}, ...}) = eventual typeof | firstArg(FunctionType{arg, ...}) = eventual arg | firstArg t = t (* Returns an instance of an overloaded function using the supplied list of type constructors for the overloading. *) fun generaliseOverload(t, constrs, isConverter) = let (* Returns the result type of a function. *) fun getResult(FunctionType{result, ...}) = eventual result | getResult _ = raise InternalError "getResult - not a function"; val arg = if isConverter then getResult t else firstArg t in case arg of TypeVar tv => let (* The argument should be a type variable, possibly set to an empty overload set. This should be replaced by the current overload set in the copied function type. *) val newSet = mkOverloadSet constrs val (t, _) = generaliseTypes(t, fn old => if sameTv(old, tv) then SOME newSet else NONE) in (t, [newSet]) end | _ => raise InternalError "generaliseOverload - arg is not a type var" end (* Prints out a type constructor e.g. type 'a fred = 'a * 'a or datatype 'a joe = bill of 'a list | mary of 'a * int or simply type 'a abs if the type is abstract. *) fun displayTypeConstrsWithMap ( TypeConstrSet( TypeConstrs{identifier=TypeId{idKind=TypeFn(args, result), ...}, name, ...}, []), depth, typeEnv, sigMap) = (* Type function *) if depth <= 0 then PrettyString "..." else let val typeV = varNameSequence () (* Local sequence for this binding. *) in PrettyBlock (3, false, [], PrettyString "type" :: PrettyBreak (1, 0) :: printTypeVars (args, depth, typeV) @ [ PrettyString (#second(splitString name)), PrettyBreak(1, 0), PrettyString "=", PrettyBreak(1, 0), tDisp(result, depth-1, typeV, typeEnv, sigMap) ] ) end | displayTypeConstrsWithMap (TypeConstrSet(tCons, [] (* No constructors *)), depth, _, _) = (* Abstract type or type in a signature. *) if depth <= 0 then PrettyString "..." else PrettyBlock (3, false, [], PrettyString ( if tcEquality tCons then "eqtype" else "type") :: PrettyBreak (1, 0) :: printTypeVars (tcTypeVars tCons, depth, varNameSequence ()) @ [PrettyString (#second(splitString(tcName tCons)))] ) | displayTypeConstrsWithMap (TypeConstrSet(tCons as TypeConstrs{name, locations, ...}, tcConstructors), depth, typeEnv, sigMap) = (* It has constructors - datatype declaration *) if depth <= 0 then PrettyString "..." else let val typeV = varNameSequence () (* Construct a ('a, 'b, 'c) tyCons construction for the result types of each of the constructors. N.B. We use the original type constructors because they have the appropriate equality type properties. datatype 'a t = A of 'a is not the same as ''a t = A of ''a. *) val typeVars = tcTypeVars tCons val typeResult = mkTypeConstruction(name, tCons, map TypeVar typeVars, locations) (* Print a single constructor (blocked) *) fun pValConstr (first, name, typeOf, depth) = let val (t, _) = generalise typeOf val firstBreak = PrettyBreak (1, if first then 2 else 0) in case t of FunctionType { arg, result} => let (* Constructor with an argument. The constructor "type" is the argument. We have to unify the result type of the function with the ('a, 'b, 'c) tyCons type so that we get the correct type variables in the argument. We just print the argument of the function. *) val _ = unifyTypes(result, typeResult) in [ firstBreak, PrettyBlock (0, false, [], PrettyBlock (0, false, [], (if first then PrettyBreak (0, 2) else PrettyBlock (0, false, [], [PrettyString "|", PrettyBreak(1, 2)]) ) :: (if depth <= 0 then [PrettyString "..."] else [ PrettyString name, PrettyBreak (1, 4), PrettyString "of"]) ) :: (if depth > 0 then [ PrettyBreak (1, 4), (* print the type as a single block of output *) tDisp (arg, depth - 1, typeV, typeEnv, sigMap) ] else []) ) ] end | _ => [ firstBreak, PrettyBlock (0, false, [], [if first then PrettyBreak (0, 2) else PrettyBlock (0, false, [], [PrettyString "|", PrettyBreak(1, 2)]), PrettyString (if depth <= 0 then "..." else name)] ) ] end (* Print a sequence of constructors (unblocked) *) fun pValConstrRest ([], _ ): pretty list = [] | pValConstrRest (H :: T, depth): pretty list = if depth < 0 then [] else pValConstr (false, valName H, valTypeOf H, depth) @ pValConstrRest (T, depth - 1) fun pValConstrList ([], _ ) = PrettyString "" (* shouldn't occur *) | pValConstrList (H :: T, depth) = PrettyBlock (2, true, [], pValConstr (true, valName H, valTypeOf H, depth) @ pValConstrRest (T, depth - 1) ) in PrettyBlock(0, false, [], [ PrettyBlock(0, false, [], PrettyString "datatype" :: PrettyBreak (1, 2) :: printTypeVars (typeVars, depth, typeV) @ [ PrettyString(#second(splitString(tcName tCons))), PrettyBreak(1, 0), PrettyString "=" ] ), pValConstrList (tcConstructors, depth - 1) ] ) end (* displayTypeConstrsWithMap *) fun displayTypeConstrs (tCons : typeConstrSet, depth : FixedInt.int, typeEnv) : pretty = displayTypeConstrsWithMap(tCons, depth, typeEnv, NONE) (* Return a type constructor from an overload. If there are several (i.e. the overloading has not resolved to a single type) it returns the "best". This is called in the third pass so it should never be called if there is not at least one type that is possible. *) fun typeConstrFromOverload(f, _) = let fun prefType(TypeVar tvar) = ( (* If we still have an overload set that's because it has not reduced to a single type. In ML 97 we default to int, real, word, char or string in that order. This works correctly for overloading literals so long as the literal conversion functions are correctly installed. *) case tvValue tvar of OverloadSet{typeset} => let (* If we accept this type we have to freeze the overloading to this type. I'm not happy about doing this here but it seems the easiest solution. *) fun freezeType tcons = ( tvSetValue(tvar, mkTypeConstruction(tcName tcons, tcons, [], [])); tcons ) in case preferredOverload typeset of SOME tycons => freezeType tycons | NONE => raise InternalError "typeConstrFromOverload: No matching type" end | _ => raise InternalError "typeConstrFromOverload: No matching type" (* Unbound or flexible record. *) ) | prefType(TypeConstruction{constr, args, ...}) = if not (tcIsAbbreviation constr) then constr (* Generally args will be nil in this case but in the special case of looking for an equality function for 'a ref or 'a array it may not be. *) else prefType (makeEquivalent (constr, args)) | prefType _ = raise InternalError "typeConstrFromOverload: No matching type" in prefType(firstArg(eventual f)) end; (* Return the result type of a function. Also used to test if the value is a function type. *) fun getFnArgType t = case eventual t of FunctionType {arg, ... } => SOME arg | _ => NONE (* Assigns type variables to variables with generalisation permitted if their level is at least that of the current level. In ML90 mode this produced an error message for any top-level free imperative type variables. We don't do that in ML97 because it is possible that another declaration may "freeze" the type variable before the composite expression reaches the top level. *) fun allowGeneralisation (t, level, nonExpansive, lex, location, moreInfo, typeEnv) = let fun giveError(s1: string, s2: string) = let (* Use a single sequence. *) val vars : typeVarForm -> string = varNameSequence (); open DEBUG val parameters = debugParams lex val errorDepth = getParameter errorDepthTag parameters in reportError lex { hard = true, location = location, message = PrettyBlock (3, false, [], [ PrettyString s1, PrettyBreak (1, 0), tDisp (t, errorDepth, vars, typeEnv, NONE), PrettyBreak (1, 0), PrettyString s2 ] ), context = SOME(moreInfo ()) } end local open DEBUG val parameters = debugParams lex in val checkOverloadFlex = getParameter narrowOverloadFlexRecordTag parameters end fun general t (genArgs as (showError, nonExpansive)) = case eventual t of TypeVar tvar => let val argSet = if tvLevel tvar >= level andalso tvLevel tvar <> generalisable andalso (case tvValue tvar of OverloadSet _ => false | _ => true) then let (* Make a new generisable type variable, except that type variables in an expansive context cannot be generalised. We also don't generalise if this is an overload set. The reason for that is that it allows us to get overloading information from the surrounding context. e.g. let fun f x y = x+y in f 2.0 end. An alternative would be take the default type (in this case int). DCJM 1/9/00. *) val nonCopiable = not nonExpansive val newLevel = if nonCopiable then level-1 else generalisable (* copiable *); val isOk = (* If the type variable has top-level scope then we have a free type variable. We only want to generate this message once even if we have multiple type variables.*) (* If the type variable is non-unifiable and the expression is expansive then we have an error since this will have to be a monotype. *) if tvNonUnifiable tvar andalso nonCopiable andalso showError then ( giveError("Type", "includes a free type variable"); false ) else showError; (* It may be a flexible record so we have to transfer the record to the new variable. *) val newTypeVar = makeTv {value=tvValue tvar, level=newLevel, equality=tvEquality tvar, nonunifiable=if nonCopiable then (tvNonUnifiable tvar) else false, printable=tvPrintity tvar} in tvSetValue (tvar, TypeVar newTypeVar); (* If we are using the "narrow" context for overloading and flexible records we should apply this here. Otherwise it is dealt with in the next pass when we have the full program context. *) case (checkOverloadFlex, tvValue tvar) of (true, LabelledType _) => giveError("Type", "is an unresolved flexible record") | (true, OverloadSet {typeset, ...}) => ( (* Set this to the "preferred" type. Typically this is "int" but for overloaded literals (e.g. 0w0) it could be something else. *) case preferredOverload typeset of SOME tycons => tvSetValue(tvar, mkTypeConstruction(tcName tycons, tycons, [], [])) | NONE => raise InternalError "general: No matching type" ) | _ => (); (isOk, nonExpansive) end else genArgs in general (tvValue tvar) argSet (* Process any flexible record. *) end | TypeConstruction {args, constr, ...} => (* There is a pathological case here. If we have a type equivalence which contains type variables that do not occur on the RHS (e.g. type 'a t = int) then we generalise over them even with an expansive expression. This is because the semantics treats type abbreviations as type functions and so any type variables that are eliminated by the function application do not appear in the "type" that the semantics applies to the expression. *) if tcIsAbbreviation constr then let val (r1, _) = general(makeEquivalent (constr, args)) genArgs (* Process any arguments that have not been processed in the equivalent. *) val (r2, _) = List.foldr (fn (t, v) => general t v) (r1, true) args in (r2, nonExpansive) end else List.foldr (fn (t, v) => general t v) genArgs args | FunctionType {arg, result} => general arg (general result genArgs) | LabelledType {recList,...} => List.foldr (fn ({ typeof, ... }, v) => general typeof v) genArgs recList | _ => genArgs in general t (true, nonExpansive); () end (* end allowGeneralisation *); (* Check for free type variables at the top level. Added for ML97. This replaces the test in allowGeneralisation above and is applied to all top-level values including those in structures and functors. *) (* I've changed this from giving an error message, which prevented the code from evaluating, to giving a warning and setting the type variables to unique type variables. That allows, for example, fun f x = raise x; f Subscript; to work. DCJM 8/3/01. *) fun checkForFreeTypeVariables(valName: string, ty: types, lex: lexan, printAndEqCode) : unit = let (* Generate new names for the type constructors. *) val count = ref 0 fun genName num = (if num >= 26 then genName (num div 26 - 1) else "") ^ String.str (Char.chr (num mod 26 + Char.ord #"a")); fun checkTypes (TypeVar tvar) () = if isEmpty(tvValue tvar) andalso tvLevel tvar = 1 then (* The type variable is unbound (specifically, not an overload set) and it is not generic i.e. it must have come from an expansive expression. *) let val name = "_" ^ genName(!count) val _ = count := !count + 1; val declLoc = location lex (* Not correct but OK for the moment. *) val declDescription = { location = declLoc, name = name, description = "Constructed from a free type variable." } val tCons = makeTypeConstructor (name, [], makeFreeId(0, Global(printAndEqCode()), tvEquality tvar, declDescription), [DeclaredAt declLoc]); val newVal = mkTypeConstruction(name, tCons, [], []) in warningMessage(lex, location lex, concat["The type of (", valName, ") contains a free type variable. Setting it to a unique monotype."]); tvSetValue (tvar, newVal) end else () | checkTypes _ () = () in foldType checkTypes ty (); () end (* Returns true if a type constructor permits equality. *) fun permitsEquality constr = if tcIsAbbreviation constr then typePermitsEquality( mkTypeConstruction (tcName constr, constr, List.map TypeVar (tcTypeVars constr), [])) else tcEquality constr and typePermitsEquality ty = equality (ty, fn _ => No, fn _ => Yes) <> No (* See if a type abbreviation or "where type" has the form type t = s or type 'a t = 'a s etc and so is simply giving a new name to the type constructor. If it is it then checks that the type constructor used (s in this example) is just a simple type name. *) fun typeNameRebinding(typeArgs, typeResult): typeId option = let fun eqTypeVar(TypeVar ta, tb) = sameTv (ta, tb) | eqTypeVar _ = false in case typeResult of TypeConstruction {constr, args, ... } => if not (ListPair.allEq eqTypeVar(args, typeArgs)) then NONE else ( case tcIdentifier constr of TypeId{idKind=TypeFn _, ...} => NONE | tId => SOME tId ) | _ => NONE end (* Returns the number of the entry in the list. Used to find out the location of fields in a labelled record for expressions and pattern matching. Assumes that the label appears in the list somewhere. *) fun entryNumber (label, LabelledType{recList, ...}) = let (* Count up the list. *) fun entry ({name, ...}::l) n = if name = label then n else entry l (n + 1) | entry [] _ = raise Match in entry recList 0 end | entryNumber (label, TypeVar tvar) = entryNumber (label, tvValue tvar) | entryNumber (label, TypeConstruction{constr, ...}) = (* Type alias *) entryNumber (label, tcEquivalent constr) | entryNumber _ = raise InternalError "entryNumber - not a record" (* Size of a labelled record. *) fun recordWidth (LabelledType{recList, ...}) = length recList | recordWidth (TypeVar tvar) = recordWidth (tvValue tvar) | recordWidth (TypeConstruction{constr, ...}) = (* Type alias *) recordWidth (tcEquivalent constr) | recordWidth _ = raise InternalError "entryNumber - not a record" fun recordFieldMap f (LabelledType{recList, ...}) = List.map (f o (fn {typeof, ...} => typeof)) recList | recordFieldMap f (TypeVar tvar) = recordFieldMap f (tvValue tvar) | recordFieldMap f (TypeConstruction{constr, ...}) = recordFieldMap f (tcEquivalent constr) | recordFieldMap _ _ = raise InternalError "entryNumber - not a record" (* Unify two type variables which would otherwise be non-unifiable. Used when we have found a local type variable with the same name as a global one. *) fun linkTypeVars (a, b) = let val ta = typesTypeVar (eventual(TypeVar a)); (* Must both be type vars. *) val tb = typesTypeVar (eventual(TypeVar b)); in (* Set the one with the higher level to point to the one with the lower, so that the effective level is the lower. *) if (tvLevel ta) > (tvLevel tb) then tvSetValue (ta, TypeVar b) else tvSetValue (tb, TypeVar a) end; (* Set its level by setting it to a new type variable. *) fun setTvarLevel (typ, level) = let val tv = typesTypeVar (eventual(TypeVar typ)); (* Must be type var. *) in tvSetValue (tv, mkTypeVar (level, tvEquality tv, true, tvPrintity tv)) end; (* Construct the least general type from a list of types. This is used after type checking to try to remove polymorphism from local values. It takes the list of actual uses of the value, usually a function, and removes any unnecessary polymorphism. This is particularly the case if the function involves a flexible record, where the unspecified fields are treated as polymorphic, but where the function is actually applied to a records which are monomorphic. *) fun leastGeneral [] = EmptyType (* Never used? *) (* Don't use this at the moment - see the comment on TypeVar below. Also the comment on TypeConstruction for local datatypes. *) (* | leastGeneral [oneType] = oneType *)(* Just one - this is it. *) | leastGeneral(firstType::otherTypes): types = let fun canonical (typ as TypeVar tyVar) = ( case tvValue tyVar of EmptyType => typ | OverloadSet _ => let val constr = typeConstrFromOverload(typ, false) in mkTypeConstruction(tcName constr, constr, [], []) end | t => canonical t ) | canonical (typ as TypeConstruction { constr, args, ...}) = if tcIsAbbreviation constr (* Handle type abbreviations directly *) then canonical(makeEquivalent (constr, args)) else typ | canonical typ = typ (* Take the head of the each argument list and extract the least general. Then process the tail. It's an error if each element of the list does not contain the same number of items. *) fun leastArgs ([]::_) = [] | leastArgs (args as _::_) = leastGeneral(List.map hd args) :: leastArgs (List.map tl args) | leastArgs _ = raise Empty in case canonical firstType of (*typ as *)TypeVar _(*tv*) => let (*fun sameTypeVar(TypeVar tv1) = sameTv(tv, tv1) | sameTypeVar _ = false*) in (* If they are all the same type variable return that otherwise return a new generalisable type variable. They may all be equal if we always apply this function to a value whose type is a polymorphic type in the function that contains all these uses. *) (* Temporarily, at least, create a new type var in this case. If we have a polymorphic function that is only used inside another polymorphic function but isn't declared inside it, if we use the caller's type variable here the call won't be recognised as polymorphic. *) (*if List.all sameTypeVar otherTypes then typ else*) mkTypeVar(generalisable, false, false, false) end | TypeConstruction{ constr, args, name, locations, ...} => ( (* There is a potential problem if the datatype is local including if it was constructed in a functor. Almost always it will have been declared after the polymorphic function but if it happens not to have been we could set a polymorphic function to a type that doesn't exist yet. To avoid this we don't allow a local datatype here and instead fall back to the polymorphic case. *) case tcIdentifier constr of thisConstrId as TypeId{access=Global _, ...} => let val argLength = List.length args (* This matches if it is an application of the same type constructor. *) fun getTypeConstrs(TypeConstruction{constr, args, ...}) = if sameTypeId(thisConstrId, tcIdentifier constr) andalso List.length args = argLength then SOME args else NONE | getTypeConstrs _ = NONE val allArgs = List.mapPartial (getTypeConstrs o canonical) otherTypes in if List.length allArgs = List.length otherTypes then TypeConstruction{constr=constr, name=name, locations=locations, args = leastArgs(args :: allArgs)} else (* At least one of these wasn't the same type constructor. *) mkTypeVar(generalisable, false, false, false) end | _ => mkTypeVar(generalisable, false, false, false) ) | FunctionType{ arg, result } => let fun getFuns(FunctionType{arg, result}) = SOME(arg, result) | getFuns _ = NONE val argResults = List.mapPartial (getFuns o canonical) otherTypes in if List.length argResults = List.length otherTypes then let val (args, results) = ListPair.unzip argResults in FunctionType{arg=leastGeneral(arg::args), result = leastGeneral(result::results)} end else (* At least one of these wasn't a function. *) mkTypeVar(generalisable, false, false, false) end | LabelledType (r as {recList=firstRec, fullList}) => if recordIsFrozen r then let (* This matches if all the field names are the same. Extract the types. *) fun nameMatch({name=name1: string, ...}, {name=name2, ...}) = name1 = name2 fun getRecords(LabelledType{recList, ...}) = if ListPair.allEq nameMatch (firstRec, recList) then SOME(List.map #typeof recList) else NONE | getRecords _ = NONE val argResults = List.mapPartial (getRecords o canonical) otherTypes in if List.length argResults = List.length otherTypes then let (* Use the names from the first record (they all are the same) to build a new record. *) val argTypes = leastArgs(List.map #typeof firstRec :: argResults) fun recreateRecord({name, ...}, types) = {name=name, typeof=types} val newList = ListPair.map recreateRecord(firstRec, argTypes) in LabelledType{recList=newList, fullList=fullList } end else (* At least one of these wasn't a record. *) mkTypeVar(generalisable, false, false, false) end else (* At this stage the record should be frozen if the program is correct but if it isn't we could have a flexible record which we report elsewhere. *) mkTypeVar(generalisable, false, false, false) | _ => (* May arise if there's been an error. *) mkTypeVar(generalisable, false, false, false) end (* Test if this is floating point i.e. the "real" type. We could include abbreviations of real as well but it's probably not worth it. *) datatype floatKind = FloatDouble | FloatSingle local val realId = tcIdentifier realConstr and floatId = tcIdentifier floatConstr fun isFloatId constr = let val id = tcIdentifier constr in if sameTypeId(id, realId) then SOME FloatDouble else if sameTypeId(id, floatId) then SOME FloatSingle else NONE end in fun isFloatingPt(TypeConstruction{args=[], constr, ...}) = isFloatId constr | isFloatingPt(OverloadSet {typeset, ...}) = ( case preferredOverload typeset of SOME t => isFloatId t (* real only. float is never preferred. *) | NONE => NONE ) | isFloatingPt(TypeVar tv) = isFloatingPt (tvValue tv) | isFloatingPt _ = NONE end fun checkDiscard(t: types, lex: lexan): string option = let open DEBUG val checkLevel = getParameter reportDiscardedValuesTag (debugParams lex) fun isUnit(LabelledType{recList=[], ...}) = true (* Unit is actually an empty record *) | isUnit(TypeConstruction{ constr as TypeConstrs{identifier=TypeId{idKind=TypeFn _, ...}, ...}, args, ...}) = isUnit(makeEquivalent(constr, args)) | isUnit(TypeVar _) = true (* Allow unbound type vars *) | isUnit _ = false fun isAFunction(FunctionType _) = true | isAFunction(TypeConstruction{ constr as TypeConstrs{identifier=TypeId{idKind=TypeFn _, ...}, ...}, args, ...}) = isAFunction(makeEquivalent(constr, args)) | isAFunction _ = false in case checkLevel of 1 => if isAFunction (eventual t) then SOME "A function value is being discarded." else NONE | 2 => if isUnit (eventual t) then NONE else SOME "A non unit value is being discarded." | _ => NONE end structure Sharing = struct type types = types and values = values and typeId = typeId and structVals = structVals and typeConstrs= typeConstrs and typeConstrSet=typeConstrSet and typeParsetree = typeParsetree and locationProp = locationProp and pretty = pretty and lexan = lexan and ptProperties = ptProperties and typeVarForm = typeVarForm and codetree = codetree and matchResult = matchResult and generalMatch = generalMatch end end (* TYPETREE *); diff --git a/mlsource/MLCompiler/VALUE_OPS.ML b/mlsource/MLCompiler/VALUE_OPS.ML index de28adb1..f60d613e 100644 --- a/mlsource/MLCompiler/VALUE_OPS.ML +++ b/mlsource/MLCompiler/VALUE_OPS.ML @@ -1,1321 +1,1321 @@ (* Copyright (c) 2000 Cambridge University Technical Services Limited Modified David C.J. Matthews 2008-9, 2013, 2015-16, 2020. This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) (* Title: Operations on global and local values. Author: Dave Matthews, Cambridge University Computer Laboratory Copyright Cambridge University 1986 *) functor VALUE_OPS ( structure LEX : LEXSIG; structure CODETREE : CODETREESIG structure STRUCTVALS : STRUCTVALSIG; structure TYPESTRUCT : TYPETREESIG structure PRINTTABLE : PRINTTABLESIG structure UNIVERSALTABLE: sig type universal = Universal.universal type univTable val app: (string * universal -> unit) -> univTable -> unit end; -structure DEBUG : DEBUGSIG +structure DEBUG : DEBUG structure MISC : sig exception InternalError of string; (* compiler error *) exception Conversion of string (* string to int conversion failure *) val quickSort : ('a -> 'a -> bool) -> 'a list -> 'a list end; structure PRETTY : PRETTYSIG structure ADDRESS : AddressSig structure UTILITIES : sig val splitString: string -> { first:string,second:string } end; structure COPIER: COPIERSIG structure TYPEIDCODE: TYPEIDCODESIG structure DATATYPEREP: DATATYPEREPSIG sharing STRUCTVALS.Sharing = TYPESTRUCT.Sharing = LEX.Sharing = PRETTY.Sharing = COPIER.Sharing = CODETREE.Sharing = PRINTTABLE = ADDRESS = UNIVERSALTABLE = MISC = TYPEIDCODE.Sharing = DATATYPEREP.Sharing ) : VALUEOPSSIG = (*****************************************************************************) (* VALUEOPS functor body *) (*****************************************************************************) struct open MISC; open PRETTY; open LEX; open CODETREE; open TYPESTRUCT; (* Open this first because unitType is in STRUCTVALS as well. *) open Universal; (* for tag etc. *) open STRUCTVALS; open PRINTTABLE; open DEBUG; open ADDRESS; open UTILITIES; open TYPEIDCODE open COPIER open DATATYPEREP (* Functions to construct the values. *) fun mkGconstr (name, typeof, code, nullary, constrs, location) = makeValueConstr (name, typeof, nullary, constrs, Global code, location); (* Global variable *) fun mkGvar (name, typeOf, code, locations) : values = Value{ name = name, typeOf = typeOf, access = Global code, class = ValBound, locations = locations, references = NONE, instanceTypes=NONE }; (* Local variable - Generated by the second pass. *) local fun makeLocalV class (name, typeOf, locations) = Value{ name = name, typeOf = typeOf, access = Local {addr = ref ~1 (* Must be set later *), level = ref baseLevel}, class = class, locations = locations, references = makeRef(), instanceTypes=SOME(ref []) }; in val mkValVar = makeLocalV ValBound and mkPattVar = makeLocalV PattBound end (* Value in a local structure or a functor argument. May be simple value, exception or constructor. *) fun mkSelectedVar (Value { access = Formal addr, name, typeOf, class, locations, ...}, Struct{access=sAccess, ...}, openLocs) = (* If the argument is "formal" set the base to the base structure. *) let (* If the base structure is a constant do the selection now. This is redundant unless we're being called from PolyML.NameSpace.Structures.contents. *) val access = case sAccess of Global code => Global(mkInd (addr, code)) | _ => Selected{addr=addr, base=sAccess} in Value{name=name, typeOf=typeOf, class=class, access=access, locations=openLocs @ locations, references = NONE, instanceTypes=NONE} end | mkSelectedVar (Value { access = Global code, name, typeOf, class, locations, ...}, _, openLocs) = (* Global: We need to add the location information. *) Value{name=name, typeOf=typeOf, class=class, access=Global code, locations=openLocs @ locations, references = NONE, instanceTypes=NONE} | mkSelectedVar(selected, _, _) = selected (* Overloaded? *); (* Construct a global exception. *) fun mkGex (name, typeof, code, locations) = Value{ name = name, typeOf = typeof, access = Global code, class = Exception, locations = locations, references = NONE, instanceTypes=NONE } (* Construct a local exception. *) fun mkEx (name, typeof, locations) = Value{ name = name, typeOf = typeof, access = Local{addr = ref 0, level = ref baseLevel}, class = Exception, locations=locations, references = NONE, instanceTypes=NONE } (* Locations in exception packets. In order to have a defined ordering of the fields, when we put the location in an exception packet we use this datatype rather than the "location" type. *) (* *) datatype RuntimeLocation = NoLocation | SomeLocation of (* file: *) string * (*startLine:*) int * (*startPosition:*) int * (*endLine:*) int * (*endPosition:*) int fun codeLocation({file="", startLine=0, startPosition=0, ...}) = mkConst(toMachineWord NoLocation) (* No useful information *) | codeLocation({file, startLine, startPosition, endLine, endPosition}) = mkConst(toMachineWord(file, startLine, startPosition, endLine, endPosition)) (*****************************************************************************) (* Look-up functions. *) (* These are used locally and also exported to INITIALISE to be used in PolyML.NameSpace.Structures.contents. *) fun makeSelectedValue( Value{ name, typeOf, access, class, locations, ... }, baseStruct as Struct{signat=Signatures { typeIdMap, ...}, name=baseName, ...}) = let fun copyId(TypeId{idKind=Bound{ offset, ...}, ...}) = SOME(typeIdMap offset) | copyId _ = NONE val copiedType = copyType (typeOf, fn x => x, fn tcon => copyTypeConstr (tcon, copyId, fn x => x, fn s => baseName^"."^s)) val baseLoc = case List.find (fn DeclaredAt _ => true | _ => false) locations of SOME (DeclaredAt loc) => [StructureAt loc] | _ => [] in mkSelectedVar ( Value{ name=name, typeOf=copiedType, access=access, class=class, locations=locations, references = NONE, instanceTypes=NONE }, baseStruct, baseLoc) end fun makeSelectedStructure( Struct {signat, access, name=structName, locations, ...}, Struct {signat=Signatures { typeIdMap, firstBoundIndex, ...}, access=baseAccess, ...}) = let val Signatures { name=sigName, tab, typeIdMap = childMap, locations=sigLocs, ... } = signat (* We need to apply the map from the parent structure to the child. *) val copiedSig = makeSignature(sigName, tab, firstBoundIndex, sigLocs, composeMaps(childMap, typeIdMap), []) (* Convert Formal access to Selected and leave the others (Global?). If this is Formal but the base structure is global do the selection now. This is only needed if we're called from PolyML.NameSpace.Structures.contents. *) val newAccess = case (access, baseAccess) of (Formal sel, Global code) => Global(mkInd(sel, code)) | (Formal sel, baseAccess) => Selected { addr = sel, base = baseAccess } | (access, _) => access (* If we have a DeclaredAt location for the structure use this as the StructureAt.*) val baseLoc = case List.find (fn DeclaredAt _ => true | _ => false) locations of SOME (DeclaredAt loc) => [StructureAt loc] | _ => [] in Struct { name = structName, signat = copiedSig, access = newAccess, locations = baseLoc @ locations} end fun makeSelectedType(typeConstr, Struct { signat=Signatures { typeIdMap, ...}, name, ...}) = fullCopyDatatype(typeConstr, typeIdMap, name^".") (* Look up a structure. *) fun lookupStructure (kind, {lookupStruct:string -> structVals option}, name, errorMessage) = let val {first = prefix, second = suffix} = splitString name; val strLookedUp = if prefix = "" then lookupStruct suffix else case lookupStructure ("Structure", {lookupStruct=lookupStruct}, prefix, errorMessage) of NONE => NONE (* Already reported *) | SOME(baseStruct as Struct { signat=Signatures { tab, ... }, ...}) => let (* Look up the first part in the structure environment. *) val Env{lookupStruct, ...} = makeEnv tab in case lookupStruct suffix of SOME foundStruct => SOME(makeSelectedStructure(foundStruct, baseStruct)) | NONE => NONE end in case strLookedUp of SOME s => SOME s | NONE => (* Not declared? *) (errorMessage (kind ^ " (" ^ suffix ^ ") has not been declared" ^ (if prefix = "" then "" else " in structure " ^ prefix)); NONE) end fun mkEnv x = let val Env e = makeEnv x in e end (* Look up a structure but ignore the access. This is used in sharing constraints where we're only interested in the signature. *) (* It's simpler to use the common code for this. *) fun lookupStructureAsSignature (lookupStruct, name, errorMessage) = lookupStructure("Structure", { lookupStruct = lookupStruct}, name, errorMessage) (* Look up a value, possibly in a structure. If it is in a structure we may have to apply a selection. *) fun lookupValue (kind, {lookupVal,lookupStruct}, name, errorMessage) = let val {first = prefix, second = suffix} = splitString name; val found = if prefix = "" then lookupVal suffix (* Look up the first part in the structure environment. *) else case lookupStructure ("Structure", {lookupStruct=lookupStruct}, prefix, errorMessage) of NONE => SOME undefinedValue | SOME (baseStruct as Struct { signat=Signatures { tab, ...}, ...}) => ( case #lookupVal (mkEnv tab) suffix of SOME foundValue => SOME(makeSelectedValue(foundValue, baseStruct)) | NONE => NONE ) in case found of SOME v => v | NONE => (* Not declared? *) ( errorMessage (kind ^ " (" ^ suffix ^ ") has not been declared" ^ (if prefix = "" then "" else " in structure " ^ prefix)); undefinedValue ) end fun lookupTyp ({lookupType,lookupStruct}, name, errorMessage) = let val {first = prefix, second = suffix} = splitString name; val found = if prefix = "" then lookupType suffix else (* Look up the first part in the structure environment. *) case lookupStructure ("Structure", {lookupStruct=lookupStruct}, prefix, errorMessage) of NONE => SOME(TypeConstrSet(undefConstr, [])) | SOME (baseStruct as Struct { signat=Signatures { tab, ...}, ...}) => ( case #lookupType (mkEnv tab) suffix of SOME typeConstr => SOME(makeSelectedType(typeConstr, baseStruct)) | NONE => NONE ) in case found of SOME v => v | NONE => (* Not declared? *) ( errorMessage ("Type constructor" ^ " (" ^ suffix ^ ") has not been declared" ^ (if prefix = "" then "" else " in structure " ^ prefix)); TypeConstrSet(undefConstr, []) ) end (* Printing. *) (* Print a value given its type. *) fun printValueForType (value:machineWord, types, depth): pretty = let (* Constuct printer code applied to the argument and the depth. Code-generate and evaluate it. *) (* If this is polymorphic apply it to a dummy set of instance types. This may happen if we have val it = NONE at the top level. The equality attributes of the type variables must match so that this works correctly with justForEqualityTypes set. *) val addrs = ref 0 (* Make local declarations for any type values. *) local fun mkAddr n = !addrs before (addrs := !addrs + n) in val typeVarMap = TypeVarMap.defaultTypeVarMap(mkAddr, baseLevel) end val dummyTypes = List.map(fn tv => {value=TYPESTRUCT.unitType, equality=tvEquality tv, printity=false}) (getPolyTypeVars(types, fn _ => NONE)) val polyCode = applyToInstance(dummyTypes, baseLevel, typeVarMap, fn _ => mkConst value) val printerCode = mkEval( printerForType(types, baseLevel, typeVarMap), [mkTuple[polyCode, mkConst(toMachineWord depth)]]) val pretty = RunCall.unsafeCast( valOf(evalue(genCode(CODETREE.mkEnv(TypeVarMap.getCachedTypeValues typeVarMap, printerCode), [], !addrs)()))) in pretty end (* These are used to display the declarations made. *) fun displayFixStatus(FixStatus(name, f)): pretty = let open PRETTY val status = case f of Nonfix => PrettyString "nonfix" | Infix prec => PrettyBlock(0, false, [], [ PrettyString "infix", PrettyBreak (1, 0), PrettyString (Int.toString prec) ]) | InfixR prec => PrettyBlock(0, false, [], [ PrettyString "infixr", PrettyBreak (1, 0), PrettyString (Int.toString prec) ]) in PrettyBlock (0, false, [], [status, PrettyBreak (1, 0), PrettyString name]) end (* Returns the declaration location as the location for the context. *) fun getLocation locations = case List.find(fn DeclaredAt _ => true | _ => false) locations of SOME(DeclaredAt loc) => [ContextLocation loc] | _ => [] (* Displays value as a block, with no external formatting. This is used at the top level but it can be applied to values extracted with #lookup globalNameSpace. That can include constructors and overloaded functions. *) fun displayValues (Value{name, typeOf, class, access, locations, ...}, depth: FixedInt.int, nameSpace, sigMap): pretty = let (* Create the "val X =" part. *) fun valPart (valOrCons, isColon) = let (* If we're putting in a colon we don't need a space after an alphanumeric id but we do if it's symbolic. *) val isAlphaNumeric = let val first = String.sub(name, 0) in Char.isAlpha first orelse first = #"'" end val space = if isColon andalso isAlphaNumeric then 0 else 1 val equOrColon = if isColon then ":" else "=" in PrettyBlock (0, false, [], [ PrettyString valOrCons, PrettyBreak (1, 0), PrettyBlock(0, false, getLocation locations, [PrettyString name]), PrettyBreak (space, 0), PrettyString equOrColon ] ) end val typeEnv = (* Environment to check for type constructors. *) { lookupType = #lookupType nameSpace, lookupStruct = #lookupStruct nameSpace} in if depth <= 0 then PrettyString "..." else case class of ValBound => let (* In nearly all cases if we have Global code we will have a constant. There was one case where "!" was actually a Lambda that hadn't been code-generated. *) val value = case access of Global code => evalue code | _ => NONE val start = case value of SOME v => [ valPart("val", false), PrettyBreak (1, 0), printValueForType (v, typeOf, depth), PrettyString ":" ] | _ => [ valPart("val", true) ] in PrettyBlock (3, false, [], start @ [ PrettyBreak (1, 0), displayWithMap (typeOf, depth, typeEnv, sigMap) ]) end | Exception => (* exceptions *) PrettyBlock (0, false, [], PrettyBlock (0, false, [], [ PrettyString "exception", PrettyBreak (1, 0), PrettyBlock(0, false, getLocation locations, [PrettyString name]) ] ) :: ( case getFnArgType typeOf of NONE => [] | SOME excType => [ PrettyBreak (1, 1), PrettyString "of", PrettyBreak (1, 3), displayWithMap (excType, depth, typeEnv, sigMap) ] ) ) | Constructor _ => (* This can only occur with #lookupVal *) PrettyBlock (3, false, [], [ valPart("constructor", true), PrettyBreak (1, 0), displayWithMap (typeOf, depth, typeEnv, sigMap) ]) | PattBound => (* Can this ever occur? *) PrettyBlock (3, false, [], [ valPart("val", true), PrettyBreak (1, 0), displayWithMap (typeOf, depth, typeEnv, sigMap) ]) end (* Print global values. This is passed through the bootstrap and used in the debugger. *) fun printValues (Value{typeOf, class, access, ...}, depth) = case (class, access) of (ValBound, Global code) => printValueForType (valOf(evalue code), typeOf, depth) | _ => PrettyString "" (* Probably shouldn't occur. *) (* Prints "sig ... end" as a block, with no external formatting *) fun displaySig (Signatures{tab, typeIdMap, ...}, depth : FixedInt.int, _ : int, { lookupType, lookupStruct, ...}, sigMap: (int-> typeId) option) : pretty = let (* Construct an environment for the types. *) val Env { lookupType = strType, lookupStruct = strStr, ...} = makeEnv tab (* Construct a map for types. *) val innerMap = case sigMap of NONE => SOME typeIdMap | SOME outerMap => SOME(composeMaps(typeIdMap, outerMap)) val compositeEnv = { lookupType = fn s => case strType s of NONE => lookupType s | SOME t => SOME (t, innerMap), lookupStruct = fn s => case strStr s of NONE => lookupStruct s | SOME s => SOME (s, innerMap) } val typeEnv: printTypeEnv = { lookupType = #lookupType compositeEnv, lookupStruct = #lookupStruct compositeEnv } fun displaySpec (_, value) : pretty list = if (tagIs signatureVar value) then (* Not legal ML97 *) [ PrettyBreak(1,2), displaySignatures (tagProject signatureVar value, depth - 1, compositeEnv)] else if (tagIs structVar value) then [ PrettyBreak(1,2), displayStructures (tagProject structVar value, depth - 1, compositeEnv, innerMap)] else if (tagIs typeConstrVar value) then [ PrettyBreak(1,2), displayTypeConstrsWithMap (tagProject typeConstrVar value, depth, typeEnv, innerMap) ] else if (tagIs valueVar value) then let (* Only print variables. Constructors are printed with their type. *) val value = tagProject valueVar value; in case value of Value{class = Constructor _, ...} => [] | _ => [ PrettyBreak(1,2), (* We lookup the infix status and any exception in the global environment only. Infix status isn't a property of a structure and it's too much trouble to look up exceptions in the structure. *) displayValues (value, depth, compositeEnv, innerMap) ] end else if (tagIs fixVar value) then (* Not legal ML97 *) [ PrettyBreak(1,2), displayFixStatus (tagProject fixVar value) ] else [] (* end displaySpec *) in PrettyBlock (0, true, [], PrettyString "sig" :: ( ( if depth <= 1 (* If the depth is 1 each of the calls to displaySpec will print "..." so we replace them all by a single "..." here. *) then [PrettyBreak (1, 0), PrettyString "..."] else let val declist = ref nil : (string * universal) list ref fun addToList nv = declist := nv :: !declist (* For the moment order them by name. We may change this to order primarily by kind and secondarily by name. *) fun order (s1: string, _) (s2: string, _) = s1 > s2 in (* Put all the entries into a list. *) UNIVERSALTABLE.app addToList tab; (* Sort the list and print it. *) List.foldl (fn (a, l) => displaySpec a @ l) [] (quickSort order (!declist)) end ) @ [PrettyBreak (1, 0), PrettyString "end"] ) ) end (* displaySig *) (* Print: signature S = sig .... end *) and displaySignatures (str as Signatures{locations, name, ...}, depth : FixedInt.int, nameSpace) : pretty = if depth <= 0 then PrettyString "..." else PrettyBlock(0, false, [], [ PrettyBlock(0, false, [], [ PrettyString "signature", PrettyBreak(1, 0), PrettyBlock(0, false, getLocation locations, [PrettyString name]), PrettyBreak(1, 0), PrettyString "=" ] ), PrettyBreak (1, 2), displaySig (str, depth, 1, nameSpace, NONE) ]) (* print structure in a block (no external spacing) *) and displayStructures (Struct{name, locations, signat, ...}, depth, nameSpace, sigMap): pretty = if depth <= 0 then PrettyString "..." else PrettyBlock (0, false, [], [ PrettyBlock(0, false, [], [ PrettyString "structure", PrettyBreak(1, 0), PrettyBlock(0, false, getLocation locations, [PrettyString name]), PrettyBreak(0, 0), PrettyString ":" ] ), PrettyBreak(1, 2), displayNamedSig(signat, depth - 1, 1, nameSpace, sigMap) ]) (* Internal function for printing structures and functors. If a signature has a name print the name rather than the contents. *) and displayNamedSig(sign as Signatures{name = "", ...}, depth, space, nameSpace, sigMap) = displaySig (sign, depth, space, nameSpace, sigMap) | displayNamedSig(Signatures{name, ...}, _, _, _, _) = PrettyString name fun displayFunctors (Functor{ name, locations, arg, result, ...}, depth, nameSpace) = if depth <= 0 then PrettyString "..." else let val arg as Struct { name = argName, signat as Signatures { tab = argTab, ... }, ...} = arg val argEntries = (if argName <> "" then [ PrettyBlock(0, false, [], [PrettyString argName, PrettyBreak(0, 0), PrettyString ":"]), PrettyBreak(1, 2) ] else []) @ [ displayNamedSig (signat, depth - 1, 0, nameSpace, NONE), PrettyBreak(0, 0), PrettyString "):", PrettyBreak(1, 0) ] (* Include the argument structure name in the type environment. *) val argEnv = if argName = "" then let val Env { lookupType=lt, lookupStruct=ls, ...} = makeEnv argTab in { lookupType = fn s => case lt s of NONE => #lookupType nameSpace s | SOME t => SOME(t, NONE), lookupStruct = fn s => case ls s of NONE => #lookupStruct nameSpace s | SOME s => SOME(s, NONE) } end else { lookupType = #lookupType nameSpace, lookupStruct = fn s => if s = argName then SOME(arg, NONE) else #lookupStruct nameSpace s } in PrettyBlock (0, false, [], [ PrettyBlock(0, false, [], [ PrettyBlock(0, false, [], [ PrettyString "functor", PrettyBreak(1, 0), PrettyBlock(0, false, getLocation locations, [PrettyString name]), PrettyBreak(1, 0), PrettyString "(" ]), PrettyBreak(0, 2), PrettyBlock(0, false, [], argEntries) ]), PrettyBreak(0, 2), displayNamedSig (result, depth - 1, 1, argEnv, NONE) ] ) end (* Exported version. *) val displayValues = fn (value, depth, nameSpace) => displayValues (value, depth, nameSpace, NONE) and displayStructures = fn (str, depth, nameSpace) => displayStructures (str, depth, nameSpace, NONE) (* Code-generation. *) (* Code-generate the values. *) fun codeStruct (Struct{access, ...}, level) = (* Global structures have no code value. Instead the values are held in the values of the signature. *) codeAccess (access, level) and codeAccess (Global code, _) = code | codeAccess (Local{addr=ref locAddr, level=ref locLevel}, level) = mkLoad (locAddr, level, locLevel) (* Argument or local *) | codeAccess (Selected{addr, base}, level) = (* Select from a structure. *) mkInd (addr, codeAccess (base, level)) | codeAccess _ = raise InternalError "No access" (*****************************************************************************) (* datatype access functions *) (*****************************************************************************) (* Get the appropriate instance of an overloaded function. If the overloading has not resolved to a single type it finds the preferred type if possible (i.e. int for most overloadings, but possibly real, word, string or char for conversion functions.) *) fun getOverloadInstance(name, instance, isConv): codetree*string = let val constr = typeConstrFromOverload(instance, isConv) in (getOverload(name, constr, fn _ => raise InternalError "getOverloadInstance: Missing"), tcName constr) end (* This is only used in addPrettyPrint. There's no point in producing a lot of detailed information. *) fun checkPPType (instanceType, matchType, fnName, lex, location, moreInfo) = case unifyTypes (instanceType, matchType) of NONE => () | SOME error => let open DEBUG val parameters = LEX.debugParams lex val errorDepth = getParameter errorDepthTag parameters in reportError lex { location = location, hard = true, message = PrettyBlock(0, true, [], [ PrettyString ("Argument for " ^ fnName), PrettyBreak (1, 3), PrettyBlock(0, false, [], [ PrettyString "Required type:", PrettyBreak (1, 0), display (matchType, errorDepth, emptyTypeEnv) ]), PrettyBreak (1, 3), PrettyBlock(0, false, [], [ PrettyString "Argument type:", PrettyBreak (1, 0), display (instanceType, errorDepth, emptyTypeEnv) ]), PrettyBreak (1, 3), unifyTypesErrorReport(lex, emptyTypeEnv, emptyTypeEnv, "unify") error ]), context = SOME (moreInfo ()) } end; (* This is applied to the instance variables if it is polymorphic and bound by a val or fun binding or is a datatype constructor. *) fun applyToInstanceType(polyVars, ValBound, level, typeVarMap, code) = applyToInstance(polyVars, level, typeVarMap, code) | applyToInstanceType(polyVars, Constructor _, level, typeVarMap, code) = applyToInstance(if justForEqualityTypes then [] else polyVars, level, typeVarMap, code) | applyToInstanceType(_, PattBound, level, _, code) = code level | applyToInstanceType(_, Exception, level, _, code) = code level val arg1 = mkLoadArgument 0 (* saves a lot of garbage *) fun addStatus typ = {value=typ, equality=false, printity=false} (* Code-generate an identifier matched to a value. N.B. If the value is a constructor it returns the pair or triple representing the functions on the constructor. *) fun codeVal (Value{access = Global code, class, ...}, level: level, typeVarMap, instance, _, _) = applyToInstanceType(instance, class, level, typeVarMap, fn _ => code) | codeVal (Value{access = Local{addr=ref locAddr, level=ref locLevel}, class, ...}, level, typeVarMap, instance, _, _) = let fun loadVar level = mkLoad (locAddr, level, locLevel) (* Argument or local *) in applyToInstanceType(instance, class, level, typeVarMap, loadVar) end | codeVal (Value{access = Selected{addr, base}, class, ...}, level: level, typeVarMap, instance, _, _) = (* Select from a structure. *) applyToInstanceType(instance, class, level, typeVarMap, fn level => mkInd (addr, codeAccess (base, level))) | codeVal (Value{access = Formal _, ...}, _, _, _, _, _) = raise InternalError "codeVal - Formal" | codeVal (Value{access = Overloaded Print, ...}, _, _, [], lex, _) = (* If this appears in a structure return a null printer function. It has to have the polymorphic form with an extra lambda outside. *) let (* We should have a single entry for the type. *) open DEBUG (* The parameter is the reference used to control the print depth when the value is actually printed. *) val prettyOut = getPrintOutput (LEX.debugParams lex) in mkProc( mkProc( CODETREE.mkEnv ( [ mkNullDec (mkEval( mkConst(toMachineWord prettyOut), [ mkConst(toMachineWord(PrettyString "?")) ]) ) ], arg1 (* Returns its argument. *) ), 1, "print()", [], 0), 1, "print(P)", [], 0) end | codeVal (Value{access = Overloaded Print, ...}, level: level, typeVarMap, [{value=argType, ...}], lex, _) = let (* We should have a single entry for the type. *) open DEBUG (* The parameter is the reference used to control the print depth when the value is actually printed. *) val printDepthFun = getParameter printDepthFunTag (LEX.debugParams lex) and prettyOut = getPrintOutput (LEX.debugParams lex) val nLevel = newLevel level in (* Construct a function that gets the print code, prints it out and returns its argument. *) mkProc( CODETREE.mkEnv ( [ mkNullDec ( mkEval( mkConst(toMachineWord prettyOut), [ mkEval( printerForType(argType, nLevel, typeVarMap), [ mkTuple[arg1, mkEval(mkConst(toMachineWord printDepthFun), [CodeZero])] ]) ]) ) ], arg1 (* Returns its argument. *) ), 1, "print()", getClosure nLevel, 0) end | codeVal (Value{access = Overloaded Print, ...}, _, _, _, _, _) = raise InternalError "Overloaded Print - wrong instance type" | codeVal (Value{access = Overloaded MakeString, ...}, _, _, [], _, _) = (* If this appears in a structure produce a default version. *) mkInlproc( mkProc(mkConst(toMachineWord "?"), 1, "makestring()", [], 0), 1, "makestring(P)", [], 0) | codeVal (Value{access = Overloaded MakeString, ...}, level: level, typeVarMap, [{value=argType, ...}], _, _) = let val nLevel = newLevel level in (* Construct a function that gets the print code and prints it out using "uglyPrint". *) mkProc( mkEval( mkConst(toMachineWord uglyPrint), [ mkEval( printerForType(argType, nLevel, typeVarMap), [ mkTuple[arg1, mkConst(toMachineWord 10000)] ]) ]), 1, "makestring()", getClosure nLevel, 0) end | codeVal (Value{access = Overloaded MakeString, ...}, _, _, _, _, _) = raise InternalError "Overloaded MakeString - wrong instance type" | codeVal (Value{access = Overloaded GetPretty, ...}, level, typeVarMap, [], _, _) = let val nLevel = newLevel level in (* If this appears in a structure return a default function. *) mkProc(printerForType(badType, nLevel, typeVarMap), 1, "getPretty", getClosure nLevel, 0) end | codeVal (Value{access = Overloaded GetPretty, ...}, level: level, typeVarMap, [{value=argType, ...}], _, _) = (* Get the pretty code for the specified argument. *) printerForType(argType, level, typeVarMap) | codeVal (Value{access = Overloaded GetPretty, ...}, _, _, _, _, _) = raise InternalError "Overloaded GetPretty - wrong instance type" | codeVal (Value{access = Overloaded AddPretty, ...}, _, _, [], _, _) = (* If this appears in a structure create a function that raises an exception if run. *) mkProc( mkConst (toMachineWord (fn _ => raise Fail "addPrettyPrint: The argument type was not a simple type construction")), 1, "AddPretty(P)", [], 0) | codeVal (Value{access = Overloaded AddPretty, ...}, level: level, _, [{value=installType, ...}, {value=argPrints, ...}], lex, loc) = let (* "instance" should be (int-> 'a -> 'b -> pretty) -> unit. We need to get the 'a and 'b. This function installs a pretty printer against the type which matches 'b. The type 'a is related to type of 'b as follows: If 'b is a monotype t then 'a is ignored. If 'b is a unary type constructor 'c t then 'a must have type 'c * int -> pretty. If 'b is a binary or higher type constructor e.g. ('c, 'd, 'e) t then 'a must be a tuple of functions of the form ('c * int -> pretty, 'd * int -> pretty, 'e * int -> pretty). When the installed function is called it will be passed the appropriate argument functions which it can call to print the argument types. *) val pretty = mkTypeVar (generalisable, false, false, false); (* Temporary hack. *) (* Find the last type constructor in the chain. We have to install this against the last in the chain because type constructors in different modules may be at different points in the chain. *) (* This does mean that it's not possible to install a pretty printer for a type constructor rather than a datatype. *) fun followTypes (TypeConstruction{constr, args, ...}) = if not (tcIsAbbreviation constr) then SOME(tcIdentifier constr, constr, List.length args) else followTypes (makeEquivalent (constr, args)) | followTypes (TypeVar tv) = ( case tvValue tv of EmptyType => NONE (* Unbound type variable *) | t => followTypes t ) | followTypes _ = NONE; val constrId = followTypes installType val () = case constrId of NONE => () | SOME (_, constr, arity) => let (* Check that the function tuple matches the arguments of the type we're installing for. *) (* Each entry should be a function of type 'a * int -> pretty *) fun mkFn arg = mkFunctionType(mkProductType[arg, TYPESTRUCT.fixedIntType], pretty) (* Create non-unifiable type vars to ensure this is properly polymorphic. *) val typeVars = List.tabulate(arity, fn _ => mkTypeVar (0, false, true, false)) val tupleType = case typeVars of [] => (* No arg so must have unit. *) unitType | [arg] => mkFn arg (* Just a single function. *) | args => mkProductType(List.map mkFn args) val addPPType = mkFunctionType(argPrints, mkFunctionType(installType, pretty)) val testType = mkFunctionType(tupleType, mkFunctionType( mkTypeConstruction(tcName constr, constr, typeVars, [DeclaredAt loc]), pretty)) in checkPPType(addPPType, testType, "addPrettyPrint", lex, loc, fn () => PrettyString "addPrettyPrint element functions must have type 'a * int -> pretty, 'b * int -> pretty, ... with one function for each type parameter") end; (* Only report the error when the function is run. Because addPrettyPrint is contained in the PolyML structure we may compile a reference to a polymorphic version of this for the structure record. It's replaced in the final structure by this version. *) in case constrId of SOME (typeId, _, arity) => let (* We need to transform the user-supplied function into the form required for the reference. The user function has type int -> 'b -> 'a -> pretty where 'b is either "don't care" if this is a monotype, the print function for the base type if it takes a single type argument or a tuple of base type functions if it takes more than one. The reference expects to contain a function of type 'a * int -> pretty for a monotype or a function of the form <'b1, 'b2...> -> 'a * int -> pretty if this is polytype where <...> represents poly-style multiple arguments. *) val printFunction = case arity of 0 => mkProc( mkEval( mkEval( mkEval( mkLoadClosure 0 (* The user-supplied fn *), [mkInd(1, arg1)] (* The depth *)), [CodeZero] (* Ignored args. *)), [mkInd(0, arg1)] (* Value to print *)), 1, "addPP-1", [arg1](* The user-supplied fn *), 0) | arity => let open TypeValue val args = if arity = 1 then [extractPrinter(mkLoadClosure 1)] else [mkTuple(List.tabulate(arity, fn n => extractPrinter(mkLoadClosure(n+1))))] in mkProc( mkProc( mkEval( mkEval( mkEval( mkLoadClosure 0 (* The user-supplied fn *), [mkInd(1, arg1)] (* The depth *)), args (* Base fns. *)), [mkInd(0, arg1)] (* Value to print *)), 1, "addPP-2", mkLoadClosure 0 :: List.tabulate(arity, mkLoadArgument), 0), arity, "addPP-1", [arg1], 0) end val nLevel = newLevel level in (* Generate a function that will set the "print" ref for the type to the argument function. *) mkProc( mkStoreOperation(LoadStoreMLWord{isImmutable=false}, TypeValue.extractPrinter( codeAccess(idAccess typeId, nLevel)), CodeZero, printFunction ), 1, "addPP", getClosure nLevel, 0) end | NONE => mkConst (toMachineWord (fn _ => raise Fail "addPrettyPrint: The argument type was not a simple type construction")) end | codeVal (Value{access = Overloaded AddPretty, ...}, _, _, _, _, _) = raise InternalError "Overloaded AddPretty - wrong instance type" | codeVal (Value{access = Overloaded GetLocation, ...}, _, _, _, _, _) = (* This can't be used a value: It must be called immediately. *) let fun getLoc() = raise Fail "The special function PolyML.sourceLocation cannot be used as a value" in mkConst (toMachineWord getLoc) end | codeVal (value as Value{access = Overloaded _, ...}, level: level, typeVarMap, instance, lex, lineno) = let val nLevel = newLevel level in (* AddOverload, Equal, NotEqual, TypeDep *) mkProc(applyFunction (value, arg1, nLevel, typeVarMap, instance, lex, lineno), 1, "", getClosure nLevel, 0) end (* Some of these have a more efficient way of calling them as functions. *) and applyFunction (value as Value{class=Exception, ...}, argument, level, typeVarMap, instance, lex, lineno) = let (* If we are applying it as a function we cannot be after the exception id, we must be constructing an exception packet. *) (* Get the exception id, put it in the packet with the exception name the argument and, currently, an empty location as the exception location. *) val exIden = codeVal (value, level, typeVarMap, instance, lex, lineno); in mkTuple (exIden :: mkStr (valName value) :: argument :: [mkConst(toMachineWord NoLocation)]) end | applyFunction(value as Value{class=Constructor _, ...}, argument, level, typeVarMap, argVars, lex, lineno) = let (* If this is a value constructor we need to get the construction function and use that. *) fun getConstr level = ValueConstructor.extractInjection(codeVal (value, level, typeVarMap, [], lex, lineno)) val polyConstr = applyToInstance(if justForEqualityTypes then [] else argVars, level, typeVarMap, getConstr) in (* Don't apply this "early". It might be the ref constructor and that must not be applied until run-time. The optimiser should take care of any other cases. *) mkEval (polyConstr, [argument]) end | applyFunction (value as Value{access = Overloaded oper, name = valName, ...}, argument, level, typeVarMap, instance, lex, lineno) = ( case oper of Equal => (* Get the equality function for the type. *) let (* We should have a single entry for the type. *) val argType = case instance of [{value, ...}] => value | _ => raise InternalError "Overload Equal" (* The instance type is a function so we have to get the first argument. *) val code = equalityForType(argType, level, typeVarMap) in mkEval (code, [argument]) end | NotEqual => let (* We should have a single entry for the type. *) val argType = case instance of [{value, ...}] => value | _ => raise InternalError "Overload NotEqual" (* Use the "=" function to provide inequality as well as equality. *) val code = equalityForType(argType, level, typeVarMap) val isEqual = mkEval (code, [argument]) in mkNot isEqual end | TypeDep => let val argType = case instance of [{value, ...}] => value | _ => raise InternalError "Overload TypeDep" val (code, _) = getOverloadInstance(valName, argType, false) in mkEval (code, [argument]) end | AddOverload => (* AddOverload is only intended for use by writers of library modules. It only does limited checking and should be regarded as "unsafe". *) let fun rmvars (TypeVar tv) = rmvars(tvValue tv) | rmvars t = t (* instance should be ('a->'b) -> string -> unit. For overloadings on most functions (e.g. abs and +) we are looking for the 'a, which may be a pair, but in the case of conversion functions we want the 'b. *) val (resultType, argType) = case instance of [{value=alpha, ...}, {value=beta, ...}] => (rmvars alpha, rmvars beta) | _ => (badType, badType) fun followTypes(TypeConstruction{constr as TypeConstrs {identifier = TypeId{idKind = Free _, ...},...}, ...}) = constr | followTypes(TypeConstruction{constr as TypeConstrs {identifier = TypeId{idKind = TypeFn _, ...},...}, args, ...}) = followTypes (makeEquivalent (constr, args)) | followTypes(TypeConstruction{constr = TypeConstrs {identifier = TypeId{idKind = Bound _, ...},...}, ...}) = raise Fail "Cannot install an overload within a structure or functor" | followTypes _ = raise Fail "Invalid type (not a type construction) (addOverload)" fun addOverloading (argCode: codetree) (name: string) = let val typeToUse = if size name > 4 andalso String.substring(name, 0, 4) = "conv" (* For conversion functions it's the result type we're interested in. For everything else it's the argument type. This will be a pair for functions such as "+" and a single argument for "abs". *) then resultType else case argType of LabelledType{recList=[{typeof, ...}, _], ...} => rmvars typeof | argType => argType val tcons = followTypes typeToUse in addOverload(name, tcons, argCode) end (* This function is used if we can't get the codetree at compile time. *) fun addOverloadGeneral (arg: machineWord) = addOverloading(mkConst arg) in (* This is messy but necessary for efficiency. If we simply treat addOverload as a function we would be able to pick up the additional overloading as a pointer to a function. Most overloads are small functions or wrapped calls to RTS functions and so we need to get the inline code for them. *) (* evalue raises an exception if "argument" is not a constant, or more usefully, a global value containing a constant and possibly a piece of codetree to inline. *) case evalue(argument) of SOME _ => mkConst (toMachineWord (addOverloading argument)) | NONE => mkEval (mkConst (toMachineWord addOverloadGeneral), [argument]) end | GetLocation => (* Return the current location. *) mkConst(toMachineWord lineno) | _ => (* Print, MakeString, InstallPP *) (* Just call as functions. *) (* not early *) mkEval (codeVal (value, level, typeVarMap, instance, lex, lineno), [argument]) ) (* overloaded *) | applyFunction (value, argument, level, typeVarMap, instance, lex, lineno) = mkEval (codeVal (value, level, typeVarMap, instance, lex, lineno), [argument]) (* end applyFunction *) (* If the exception is being used as a value we want an exception packet or a function to make a packet. If it is a nullary constructor make an exception packet now, otherwise generate a function to construct an exception packet. *) fun codeExFunction (value, level, typeVarMap, instance, lex, lineno) = case getFnArgType(valTypeOf value) of (* N.B. Not "instance" *) NONE => applyFunction (value, CodeZero, level, typeVarMap, List.map addStatus instance, lex, lineno) | SOME _ => let val nLevel = newLevel level in mkProc (applyFunction (value, arg1, nLevel, typeVarMap, List.map addStatus instance, lex, lineno), 1, "", getClosure nLevel, 0) end (* Operations to compile code from the representation of a constructor. *) (* Code to test whether a value matches a constructor. This must be applied to any polymorphic variables in the instance but the result is always bool so we don't create a new function if the result is also polymorphic. It is just possible to have a resulting polytype here (N.B. that's different from having a parametric type) if we have a val binding. e.g. val SOME x = SOME nil. In that case we can choose an arbitrary type for the test and have to parameterise the result. *) fun makeGuard (value as Value{class=Constructor _, ...}, argVars, testing, level, typeVarMap) = let fun tester level = ValueConstructor.extractTest(codeVal (value, level, typeVarMap, [], nullLex, location nullLex)) val testCode = applyToInstance(if justForEqualityTypes then [] else List.map addStatus argVars, level, typeVarMap, tester) in mkEval(testCode, [testing]) end | makeGuard (value as Value{class=Exception, ...}, _, testing, level, typeVarMap) = (* Should only be an exception. Get the value of the exception identifier and compare with the identifier in the exception packet. *) mkEqualPointerOrWord (mkInd (0, testing), codeVal (value, level, typeVarMap, [], nullLex, location nullLex)) | makeGuard _ = raise InternalError "makeGuard" (* Code to invert a constructor. i.e. return the value originally used as the argument. Apply to any polymorphic variables and construct a result. *) fun makeInverse(value as Value{class=Constructor{nullary=false, ...}, ...}, argVars, arg, level, typeVarMap): codetree = let fun getInverse level = ValueConstructor.extractProjection(codeVal (value, level, typeVarMap, [], nullLex, location nullLex)) val loadCode = applyToInstance(if justForEqualityTypes then [] else List.map addStatus argVars, level, typeVarMap, getInverse) in mkEval(loadCode, [arg]) end | makeInverse(Value{class=Constructor{nullary=true, ...}, ...}, _, _, _, _): codetree = (* makeInverse is called even on nullary constructors. Return zero to keep the optimiser happy. *) CodeZero | makeInverse (Value{class=Exception, ...}, _, arg, _, _) = (* Exceptions. - Get the parameter from third word *) (* We have to use a VarField here even though this field is present in every exception. The format of the value that is returned depends on the exception id. *) mkVarField (2,arg) | makeInverse _ = raise InternalError "makeInverse" (* Work out the polymorphism and the mapping between the formal type variables and the actual types. Because flexible records may introduce extra polymorphism we can only do this once we've frozen them. e.g. fun f x = #1 x + #2 x may be monomorphic or polymorphic depending on what it's subsequently applied to. *) (* Using unification here isn't ideal. We have to put the equality attribute back on to abstypes in case the unification requires it. There may be other situations where things don't work properly. *) fun getPolymorphism (Value{ typeOf, access, name, ...}, expType, typeVarMap) = let val (t, polyVars) = case access of Overloaded TypeDep => let val (t, polyVars) = generaliseOverload(typeOf, List.map #1 (getOverloads name), false) in (t, List.map (fn t => {value=t, equality=false, printity=false}) polyVars) end | _ => generaliseWithMap(typeOf, TypeVarMap.mapTypeVars typeVarMap) (* Ignore the result. There are circumstances in which we can get a unification error as the result of failing to find a fixed record type where the possible records we could find have non-unifiable types. See Tests/Fail/Test072.ML *) val _ = unifyTypes(t, expType) in polyVars end (* Convert a literal constant. We can only do this once any overloading has been resolved. *) fun getLiteralValue(converter, literal, instance, error): machineWord option = let val (conv, name) = getOverloadInstance(valName converter, instance, true) in SOME(RunCall.unsafeCast(valOf(evalue conv)) literal) handle Match => NONE (* Overload error *) | Conversion s => ( error("Conversion exception ("^s^") raised while converting " ^ literal ^ " to " ^ name); NONE ) | Overflow => ( error ("Overflow exception raised while converting " ^ literal ^ " to " ^ name); NONE ) | Thread.Thread.Interrupt => raise Thread.Thread.Interrupt | _ => ( error ("Exception raised while converting " ^ literal ^ " to " ^ name); NONE ) end (* Types that can be shared. *) structure Sharing = struct type lexan = lexan type codetree = codetree type types = types type values = values type structVals = structVals type functors = functors type valAccess = valAccess type typeConstrs = typeConstrs type typeConstrSet = typeConstrSet type signatures = signatures type fixStatus = fixStatus type univTable = univTable type pretty = pretty type locationProp = locationProp type typeId = typeId type typeVarForm = typeVarForm type typeVarMap = typeVarMap type level = level type machineWord = machineWord end end (* body of VALUEOPS *); diff --git a/polyml.pyp b/polyml.pyp index 4c3bad4d..cb9d8678 100644 --- a/polyml.pyp +++ b/polyml.pyp @@ -1,241 +1,241 @@ + - diff --git a/polymlInterpreted.pyp b/polymlInterpreted.pyp index a0779774..6de9154c 100644 --- a/polymlInterpreted.pyp +++ b/polymlInterpreted.pyp @@ -1,219 +1,219 @@ + -