From de4afaa9bd4132902199cdde8e2443a16fc69b67 Mon Sep 17 00:00:00 2001 From: Martin Elsman Date: Thu, 26 Dec 2024 00:49:20 +0100 Subject: [PATCH] simplifications --- .github/workflows/main.yml | 6 +-- src/Compiler/Backend/BACKEND_INFO.sml | 2 - src/Compiler/Backend/BackendInfo.sml | 3 +- src/Compiler/Backend/CalcOffset.sml | 11 ++-- src/Compiler/Backend/CallConv.sml | 45 +++------------- src/Compiler/Backend/ClosConvEnv.sml | 3 +- src/Compiler/Backend/ClosExp.sml | 12 +---- src/Compiler/Backend/CodeGenUtil.sml | 5 -- src/Compiler/Backend/FetchAndFlush.sml | 6 +-- src/Compiler/Backend/JumpTables.sml | 3 +- src/Compiler/Backend/LineStmt.sml | 16 ++---- src/Compiler/Backend/NativeCompile.sml | 38 ++++--------- src/Compiler/Backend/RegAlloc.sml | 6 +-- src/Compiler/Backend/SubstAndSimplify.sml | 6 +-- src/Compiler/Backend/X64/CodeGenUtilX64.sml | 60 +++++++++------------ src/Compiler/Backend/X64/CodeGenX64.sml | 14 ++--- src/Compiler/Backend/X64/ExecutionX64.sml | 20 ++----- src/Compiler/CompileBasis.sml | 17 +++--- 18 files changed, 78 insertions(+), 195 deletions(-) diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index 0f8b369ca..f52e7deb5 100644 --- a/.github/workflows/main.yml +++ b/.github/workflows/main.yml @@ -72,7 +72,7 @@ jobs: brew tap homebrew/cask mkdir phantomjs cd phantomjs - wget https://bitbucket.org/ariya/phantomjs/downloads/phantomjs-2.1.1-macosx.zip + wget -q https://bitbucket.org/ariya/phantomjs/downloads/phantomjs-2.1.1-macosx.zip unzip phantomjs-2.1.1-macosx.zip cp -p phantomjs-2.1.1-macosx/bin/phantomjs /usr/local/bin/ cd .. @@ -89,10 +89,10 @@ jobs: working-directory: ${{ env.RUNHOME }} run: | echo "[OS: $OS, HOME: $RUNHOME, THECC: ${{env.THECC}}]" - wget https://github.com/diku-dk/smlpkg/releases/download/v0.1.4/smlpkg-bin-dist-${{env.OS}}.tgz + wget -q https://github.com/diku-dk/smlpkg/releases/download/v0.1.4/smlpkg-bin-dist-${{env.OS}}.tgz tar xzf smlpkg-bin-dist-${{env.OS}}.tgz echo "$HOME/smlpkg-bin-dist-${{env.OS}}/bin" >> $GITHUB_PATH - wget https://github.com/melsman/mlkit/releases/download/v4.7.13/mlkit-bin-dist-${{env.OS}}.tgz + wget -q https://github.com/melsman/mlkit/releases/download/v4.7.13/mlkit-bin-dist-${{env.OS}}.tgz tar xzf mlkit-bin-dist-${{env.OS}}.tgz echo "$HOME/mlkit-bin-dist-${{env.OS}}/bin" >> $GITHUB_PATH mkdir -p .mlkit diff --git a/src/Compiler/Backend/BACKEND_INFO.sml b/src/Compiler/Backend/BACKEND_INFO.sml index dc40ce2f6..0cc7f4532 100644 --- a/src/Compiler/Backend/BACKEND_INFO.sml +++ b/src/Compiler/Backend/BACKEND_INFO.sml @@ -78,6 +78,4 @@ signature BACKEND_INFO = val minCodeInBinSearch : int val maxDiff : int val minJumpTabSize : int - - val down_growing_stack : bool (* true for x86/x64 code generation *) end diff --git a/src/Compiler/Backend/BackendInfo.sml b/src/Compiler/Backend/BackendInfo.sml index a03554aac..580d7019a 100644 --- a/src/Compiler/Backend/BackendInfo.sml +++ b/src/Compiler/Backend/BackendInfo.sml @@ -1,4 +1,4 @@ -functor BackendInfo(val down_growing_stack : bool) : BACKEND_INFO = +structure BackendInfo : BACKEND_INFO = struct structure PP = PrettyPrint structure Labels = AddressLabels @@ -134,5 +134,4 @@ functor BackendInfo(val down_growing_stack : bool) : BACKEND_INFO = val maxDiff = 10 val minJumpTabSize = 5 - val down_growing_stack = down_growing_stack end diff --git a/src/Compiler/Backend/CalcOffset.sml b/src/Compiler/Backend/CalcOffset.sml index 33312f9da..6469af457 100644 --- a/src/Compiler/Backend/CalcOffset.sml +++ b/src/Compiler/Backend/CalcOffset.sml @@ -1,6 +1,4 @@ -functor CalcOffset(structure CallConv: CALL_CONV - where type lvar = Lvars.lvar - structure LineStmt: LINE_STMT +functor CalcOffset(structure LineStmt: LINE_STMT where type con = Con.con where type excon = Excon.excon where type lvar = Lvars.lvar @@ -8,14 +6,15 @@ functor CalcOffset(structure CallConv: CALL_CONV where type label = AddressLabels.label where type phsize = PhysSizeInf.phsize where type StringTree = PrettyPrint.StringTree - sharing type CallConv.cc = LineStmt.cc + where type cc = CallConv.cc structure FetchAndFlush: FETCH_AND_FLUSH where type lvar = Lvars.lvar where type label = AddressLabels.label - sharing type FetchAndFlush.Atom = LineStmt.Atom - structure BI : BACKEND_INFO) + sharing type FetchAndFlush.Atom = LineStmt.Atom) : CALC_OFFSET = struct + + structure BI = BackendInfo structure PP = PrettyPrint structure Labels = AddressLabels val _ = Flags.add_bool_entry diff --git a/src/Compiler/Backend/CallConv.sml b/src/Compiler/Backend/CallConv.sml index a8c2cd998..c2c8a65f0 100644 --- a/src/Compiler/Backend/CallConv.sml +++ b/src/Compiler/Backend/CallConv.sml @@ -7,8 +7,10 @@ (* (e.g., resolve_cc, resolve_ccall, handl_arg_phreg, *) (* handl_return_phreg, resolve_act_cc) *) -functor CallConv(BI : BACKEND_INFO) : CALL_CONV = +structure CallConv : CALL_CONV = struct + + structure BI = BackendInfo type lvar = Lvars.lvar type offset = int @@ -167,47 +169,12 @@ functor CallConv(BI : BACKEND_INFO) : CALL_CONV = val ((astys,stys), (ps,regs)) = resolv (stys,(ps,regs)) val ((arstys,rstys), (ps,_)) = resolv (rstys,(ps,regs)) val ((afstys,fstys), (ps,_)) = resolv (fstys,(ps,fregs)) - val (astys',arstys',afstys') = - if BI.down_growing_stack then - let val afstys' = map assign_stack (rev fstys) - val arstys' = map assign_stack (rev rstys) - val astys' = map assign_stack (rev stys) - in (astys',arstys',afstys') - end - else - let val astys' = map assign_stack stys - val arstys' = map assign_stack rstys - val afstys' = map assign_stack fstys - in (astys', arstys',afstys') - end + val afstys' = map assign_stack (rev fstys) + val arstys' = map assign_stack (rev rstys) + val astys' = map assign_stack (rev stys) in (astys@astys', arstys@arstys', afstys@afstys', ps) end -(* - fun resolve_stys_args ([], [], (acc,ph_regs)) = ([], [], (acc,ph_regs)) - | resolve_stys_args (args_stys, reg_args_stys, (acc,[])) = (* no more phregs *) - if BI.down_growing_stack then - let val reg_args = map assign_stack (rev reg_args_stys) - val args = map assign_stack (rev args_stys) - in (args, reg_args, (acc, [])) - end - else - let val args = map assign_stack args_stys - val reg_args = map assign_stack reg_args_stys - in (args, reg_args, (acc, [])) - end - | resolve_stys_args (asty::astys, rastys, (acc,ph_reg::ph_regs)) = - let val (astys', rastys', (lv_phreg_list,ph_regs')) = resolve_stys_args (astys, rastys, (acc,ph_regs)) - val (asty', lv_phreg') = assign_phreg (asty, ph_reg) - in (asty'::astys', rastys', (lv_phreg'::lv_phreg_list,ph_regs')) - end - | resolve_stys_args ([], rasty::rastys, (acc,ph_reg::ph_regs)) = - let val (_,rastys', (lv_phreg_list,ph_regs')) = resolve_stys_args ([], rastys, (acc,ph_regs)) - val (rasty', lv_phreg') = assign_phreg (rasty, ph_reg) - in ([], rasty'::rastys', (lv_phreg'::lv_phreg_list,ph_regs')) - end -*) - fun resolve_sty_opt (SOME sty,(ps,[])) = (SOME(assign_stack sty),(ps,[])) | resolve_sty_opt (SOME sty,(ps,r::rs)) = let val (sty,p) = assign_phreg(sty,r) diff --git a/src/Compiler/Backend/ClosConvEnv.sml b/src/Compiler/Backend/ClosConvEnv.sml index d5f620f67..1266e3742 100644 --- a/src/Compiler/Backend/ClosConvEnv.sml +++ b/src/Compiler/Backend/ClosConvEnv.sml @@ -1,7 +1,8 @@ -functor ClosConvEnv(BI : BACKEND_INFO where type label = AddressLabels.label) : CLOS_CONV_ENV = +structure ClosConvEnv : CLOS_CONV_ENV = struct + structure BI = BackendInfo structure RegvarFinMap = EffVarEnv structure Labels = AddressLabels structure PP = PrettyPrint diff --git a/src/Compiler/Backend/ClosExp.sml b/src/Compiler/Backend/ClosExp.sml index 62616b3d6..9a5ac6fd6 100644 --- a/src/Compiler/Backend/ClosExp.sml +++ b/src/Compiler/Backend/ClosExp.sml @@ -1,14 +1,6 @@ -functor ClosExp(structure CallConv: CALL_CONV where type lvar = Lvars.lvar - structure ClosConvEnv: CLOS_CONV_ENV - where type con = Con.con - where type place = AtInf.place - where type excon = Excon.excon - where type lvar = Lvars.lvar - where type label = AddressLabels.label - where type phsize = PhysSizeInf.phsize - where type StringTree = PrettyPrint.StringTree - structure BI : BACKEND_INFO) : CLOS_EXP = +structure ClosExp : CLOS_EXP = struct + structure BI = BackendInfo structure PP = PrettyPrint structure Labels = AddressLabels structure RE = MulExp.RegionExp diff --git a/src/Compiler/Backend/CodeGenUtil.sml b/src/Compiler/Backend/CodeGenUtil.sml index 154d8c2df..39a5abafe 100644 --- a/src/Compiler/Backend/CodeGenUtil.sml +++ b/src/Compiler/Backend/CodeGenUtil.sml @@ -49,10 +49,6 @@ signature INSTS_COMMON = sig end functor CodeGenUtil(structure Insts : INSTS_COMMON - structure BackendInfo : BACKEND_INFO - where type label = AddressLabels.label - structure CallConv: CALL_CONV - where type lvar = Lvars.lvar structure LineStmt: LINE_STMT where type con = Con.con where type excon = Excon.excon @@ -60,7 +56,6 @@ functor CodeGenUtil(structure Insts : INSTS_COMMON where type label = AddressLabels.label where type place = Effect.effect where type StringTree = PrettyPrint.StringTree - sharing type CallConv.cc = LineStmt.cc structure SubstAndSimplify: SUBST_AND_SIMPLIFY where type ('a,'b,'c) LinePrg = ('a,'b,'c) LineStmt.LinePrg where type lvar = Lvars.lvar diff --git a/src/Compiler/Backend/FetchAndFlush.sml b/src/Compiler/Backend/FetchAndFlush.sml index 6d837bdb4..9befca96a 100644 --- a/src/Compiler/Backend/FetchAndFlush.sml +++ b/src/Compiler/Backend/FetchAndFlush.sml @@ -1,6 +1,4 @@ -functor FetchAndFlush(structure CallConv: CALL_CONV - where type lvar = Lvars.lvar - structure LineStmt: LINE_STMT +functor FetchAndFlush(structure LineStmt: LINE_STMT where type con = Con.con where type excon = Excon.excon where type lvar = Lvars.lvar @@ -8,7 +6,7 @@ functor FetchAndFlush(structure CallConv: CALL_CONV where type label = AddressLabels.label where type phsize = PhysSizeInf.phsize where type StringTree = PrettyPrint.StringTree - sharing type CallConv.cc = LineStmt.cc + where type cc = CallConv.cc structure RegAlloc: REG_ALLOC where type lvar = Lvars.lvar where type label = AddressLabels.label diff --git a/src/Compiler/Backend/JumpTables.sml b/src/Compiler/Backend/JumpTables.sml index 5093da5bc..2c6b298b0 100644 --- a/src/Compiler/Backend/JumpTables.sml +++ b/src/Compiler/Backend/JumpTables.sml @@ -1,6 +1,7 @@ -functor JumpTables(BI : BACKEND_INFO) : JUMP_TABLES = +structure JumpTables :> JUMP_TABLES = struct + structure BI = BackendInfo (***********) (* Logging *) (***********) diff --git a/src/Compiler/Backend/LineStmt.sml b/src/Compiler/Backend/LineStmt.sml index 3bc78ce57..6c1d8757a 100644 --- a/src/Compiler/Backend/LineStmt.sml +++ b/src/Compiler/Backend/LineStmt.sml @@ -1,19 +1,9 @@ -functor LineStmt(structure CallConv: CALL_CONV - where type lvar = Lvars.lvar - structure ClosExp: CLOS_EXP - where type con = Con.con - where type excon = Excon.excon - where type lvar = Lvars.lvar - where type place = Effect.effect - where type label = AddressLabels.label - where type phsize = PhysSizeInf.phsize - where type StringTree = PrettyPrint.StringTree - sharing type CallConv.cc = ClosExp.cc - structure BI : BACKEND_INFO - structure RI : REGISTER_INFO +functor LineStmt(structure RI : REGISTER_INFO where type lvar = Lvars.lvar) : LINE_STMT = struct + + structure BI = BackendInfo structure Labels = AddressLabels structure PP = PrettyPrint val _ = Flags.add_bool_entry diff --git a/src/Compiler/Backend/NativeCompile.sml b/src/Compiler/Backend/NativeCompile.sml index 8bd0e340d..8d3dbfd77 100644 --- a/src/Compiler/Backend/NativeCompile.sml +++ b/src/Compiler/Backend/NativeCompile.sml @@ -16,9 +16,8 @@ signature NATIVE_COMPILE = sig - structure CallConv : CALL_CONV - structure LineStmt : LINE_STMT - structure ClosExp : CLOS_EXP + structure LineStmt : LINE_STMT where type cc = CallConv.cc + where type lvar = Lvars.lvar structure SubstAndSimplify : SUBST_AND_SIMPLIFY type BackendEnv @@ -35,7 +34,6 @@ signature NATIVE_COMPILE = type StoreTypeCO type Aty - val compile : BackendEnv * ((place*pp)at,place*phsize,unit) LambdaPgm * bool * string(*vcg_file*) -> BackendEnv * {main_lab:label, code:(StoreTypeCO,offset,Aty) LinePrg, @@ -47,44 +45,26 @@ signature NATIVE_COMPILE = end -functor NativeCompile (structure BackendInfo : BACKEND_INFO - where type label = AddressLabels.label - structure RegisterInfo : REGISTER_INFO +functor NativeCompile (structure RegisterInfo : REGISTER_INFO where type lvar = Lvars.lvar ) : NATIVE_COMPILE = struct structure RegionExp = MulExp.RegionExp structure PP = PrettyPrint - structure ClosConvEnv = ClosConvEnv(BackendInfo) - - structure CallConv = CallConv(BackendInfo) - - structure ClosExp = ClosExp(structure ClosConvEnv = ClosConvEnv - structure BI = BackendInfo - structure CallConv = CallConv) - - structure LineStmt = LineStmt(structure CallConv = CallConv - structure ClosExp = ClosExp - structure RI = RegisterInfo - structure BI = BackendInfo) + structure LineStmt = LineStmt(structure RI = RegisterInfo) - structure RegAlloc = RegAlloc(structure CallConv = CallConv - structure LineStmt = LineStmt + structure RegAlloc = RegAlloc(structure LineStmt = LineStmt structure RI = RegisterInfo) - structure FetchAndFlush = FetchAndFlush(structure CallConv = CallConv - structure LineStmt = LineStmt + structure FetchAndFlush = FetchAndFlush(structure LineStmt = LineStmt structure RegAlloc = RegAlloc structure RI = RegisterInfo) - structure CalcOffset = CalcOffset(structure CallConv = CallConv - structure LineStmt = LineStmt - structure FetchAndFlush = FetchAndFlush - structure BI = BackendInfo) + structure CalcOffset = CalcOffset(structure LineStmt = LineStmt + structure FetchAndFlush = FetchAndFlush) - structure SubstAndSimplify = SubstAndSimplify(structure CallConv = CallConv - structure LineStmt = LineStmt + structure SubstAndSimplify = SubstAndSimplify(structure LineStmt = LineStmt structure CalcOffset = CalcOffset structure RI = RegisterInfo) diff --git a/src/Compiler/Backend/RegAlloc.sml b/src/Compiler/Backend/RegAlloc.sml index aa9f0f26f..20e3d9e12 100644 --- a/src/Compiler/Backend/RegAlloc.sml +++ b/src/Compiler/Backend/RegAlloc.sml @@ -1,13 +1,11 @@ -functor RegAlloc(structure CallConv: CALL_CONV - where type lvar = Lvars.lvar - structure LineStmt: LINE_STMT +functor RegAlloc(structure LineStmt: LINE_STMT where type con = Con.con where type excon = Excon.excon where type lvar = Lvars.lvar where type place = Effect.effect where type label = AddressLabels.label where type StringTree = PrettyPrint.StringTree - sharing type CallConv.cc = LineStmt.cc + where type cc = CallConv.cc structure RI : REGISTER_INFO where type lvar = Lvars.lvar) : REG_ALLOC = diff --git a/src/Compiler/Backend/SubstAndSimplify.sml b/src/Compiler/Backend/SubstAndSimplify.sml index 227629302..cf0279661 100644 --- a/src/Compiler/Backend/SubstAndSimplify.sml +++ b/src/Compiler/Backend/SubstAndSimplify.sml @@ -1,6 +1,4 @@ -functor SubstAndSimplify(structure CallConv: CALL_CONV - where type lvar = Lvars.lvar - structure LineStmt: LINE_STMT +functor SubstAndSimplify(structure LineStmt: LINE_STMT where type con = Con.con where type excon = Excon.excon where type lvar = Lvars.lvar @@ -8,7 +6,7 @@ functor SubstAndSimplify(structure CallConv: CALL_CONV where type label = AddressLabels.label where type phsize = PhysSizeInf.phsize where type StringTree = PrettyPrint.StringTree - sharing type CallConv.cc = LineStmt.cc + where type cc = CallConv.cc structure CalcOffset: CALC_OFFSET where type lvar = Lvars.lvar where type place = Effect.place diff --git a/src/Compiler/Backend/X64/CodeGenUtilX64.sml b/src/Compiler/Backend/X64/CodeGenUtilX64.sml index f045da827..f2d82b3dd 100644 --- a/src/Compiler/Backend/X64/CodeGenUtilX64.sml +++ b/src/Compiler/Backend/X64/CodeGenUtilX64.sml @@ -1,16 +1,10 @@ -functor CodeGenUtilX64(structure BackendInfo : BACKEND_INFO - where type label = AddressLabels.label - structure JumpTables : JUMP_TABLES - structure CallConv: CALL_CONV - where type lvar = Lvars.lvar - structure LineStmt: LINE_STMT +functor CodeGenUtilX64(structure LineStmt: LINE_STMT where type con = Con.con where type excon = Excon.excon where type lvar = Lvars.lvar where type label = AddressLabels.label where type place = Effect.effect where type StringTree = PrettyPrint.StringTree - sharing type CallConv.cc = LineStmt.cc structure SubstAndSimplify: SUBST_AND_SIMPLIFY where type ('a,'b,'c) LinePrg = ('a,'b,'c) LineStmt.LinePrg where type lvar = Lvars.lvar @@ -20,8 +14,6 @@ functor CodeGenUtilX64(structure BackendInfo : BACKEND_INFO struct local structure X = CodeGenUtil(structure Insts = InstsX64 - structure BackendInfo = BackendInfo - structure CallConv = CallConv structure LineStmt = LineStmt structure SubstAndSimplify = SubstAndSimplify) in open X @@ -52,31 +44,6 @@ struct | r12 => 12 | r13 => 13 | r14 => 14 | r15 => 15 | r => die ("lv_to_reg.no: " ^ I.pr_reg r) - (* Generate a string label *) - fun gen_string_lab str = - let val string_lab = new_string_lab() - - (* generate a .byte pseudo instuction for each character in - * the string and generate a .byte 0 instruction at the end. *) - val bytes = - foldr(fn (ch, acc) => I.dot_byte (Int.toString(ord ch)) :: acc) - [I.dot_byte "0"] (explode str) - - val () = add_static_data (I.dot_data :: - I.dot_align 8 :: - I.lab string_lab :: - I.dot_quad(BI.pr_tag_w(BI.tag_string(true,size(str)))) :: - bytes) - in string_lab - end - - (* Generate a Data label *) - fun gen_data_lab lab = add_static_data [I.dot_data, - I.dot_align 8, - I.lab (DatLab lab), - I.dot_quad (i2s BI.ml_unit)] (* was "0" but use ml_unit instead - * for GC *) - (* push_aty, i.e., rsp-=8; rsp[0] = aty (different than on hp) *) (* size_ff is for rsp before rsp is moved. *) fun push_aty (aty,t:reg,size_ff,C) = @@ -110,6 +77,31 @@ struct of SS.PHREG_ATY r => I.addq(R r, R t) :: C | _ => move_aty_into_reg(arg,tmp,size_ff, I.addq(R tmp, R t) :: C) + (* Generate a string label *) + fun gen_string_lab str = + let val string_lab = new_string_lab() + + (* generate a .byte pseudo instuction for each character in + * the string and generate a .byte 0 instruction at the end. *) + val bytes = + foldr(fn (ch, acc) => I.dot_byte (Int.toString(ord ch)) :: acc) + [I.dot_byte "0"] (explode str) + + val () = add_static_data (I.dot_data :: + I.dot_align 8 :: + I.lab string_lab :: + I.dot_quad(BI.pr_tag_w(BI.tag_string(true,size(str)))) :: + bytes) + in string_lab + end + + (* Generate a Data label *) + fun gen_data_lab lab = add_static_data [I.dot_data, + I.dot_align 8, + I.lab (DatLab lab), + I.dot_quad (i2s BI.ml_unit)] (* was "0" but use ml_unit instead + * for GC *) + (***********************) (* Calling C Functions *) (***********************) diff --git a/src/Compiler/Backend/X64/CodeGenX64.sml b/src/Compiler/Backend/X64/CodeGenX64.sml index bfc1401ee..e1c31408f 100644 --- a/src/Compiler/Backend/X64/CodeGenX64.sml +++ b/src/Compiler/Backend/X64/CodeGenX64.sml @@ -1,18 +1,13 @@ (* Generate Target Code *) -functor CodeGenX64(structure BackendInfo : BACKEND_INFO - where type label = AddressLabels.label - structure JumpTables : JUMP_TABLES - structure CallConv: CALL_CONV - where type lvar = Lvars.lvar - structure LineStmt: LINE_STMT +functor CodeGenX64(structure LineStmt: LINE_STMT where type con = Con.con where type excon = Excon.excon where type lvar = Lvars.lvar where type label = AddressLabels.label where type place = Effect.effect where type StringTree = PrettyPrint.StringTree - sharing type CallConv.cc = LineStmt.cc + where type cc = CallConv.cc structure SubstAndSimplify: SUBST_AND_SIMPLIFY where type ('a,'b,'c) LinePrg = ('a,'b,'c) LineStmt.LinePrg where type lvar = Lvars.lvar @@ -22,10 +17,7 @@ functor CodeGenX64(structure BackendInfo : BACKEND_INFO : CODE_GEN = struct - local structure X = CodeGenUtilX64(structure BackendInfo = BackendInfo - structure JumpTables = JumpTables - structure CallConv = CallConv - structure LineStmt = LineStmt + local structure X = CodeGenUtilX64(structure LineStmt = LineStmt structure SubstAndSimplify = SubstAndSimplify) in open X end diff --git a/src/Compiler/Backend/X64/ExecutionX64.sml b/src/Compiler/Backend/X64/ExecutionX64.sml index 42155ff3a..a1a9ff1de 100644 --- a/src/Compiler/Backend/X64/ExecutionX64.sml +++ b/src/Compiler/Backend/X64/ExecutionX64.sml @@ -1,26 +1,14 @@ -structure ExecutionX64: EXECUTION = +structure ExecutionX64 : EXECUTION = struct structure TopdecGrammar = PostElabTopdecGrammar structure Labels = AddressLabels structure PP = PrettyPrint + structure CompileBasis = CompileBasis - structure BackendInfo = - BackendInfo(val down_growing_stack : bool = true) (* true for x64 code generation *) + structure NativeCompile = NativeCompile(structure RegisterInfo = InstsX64.RI) - structure NativeCompile = NativeCompile(structure BackendInfo = BackendInfo - structure RegisterInfo = InstsX64.RI) - - structure ClosExp = NativeCompile.ClosExp - - structure CompileBasis = CompileBasis(structure ClosExp = ClosExp) - - structure JumpTables = JumpTables(BackendInfo) - - structure CodeGen = CodeGenX64(structure BackendInfo = BackendInfo - structure JumpTables = JumpTables - structure CallConv = NativeCompile.CallConv - structure LineStmt = NativeCompile.LineStmt + structure CodeGen = CodeGenX64(structure LineStmt = NativeCompile.LineStmt structure SubstAndSimplify = NativeCompile.SubstAndSimplify) val message = CodeGen.message diff --git a/src/Compiler/CompileBasis.sml b/src/Compiler/CompileBasis.sml index 30f8beeb6..e01516ea6 100644 --- a/src/Compiler/CompileBasis.sml +++ b/src/Compiler/CompileBasis.sml @@ -1,10 +1,5 @@ -functor CompileBasis(structure ClosExp : CLOS_EXP - where type con = CompBasis.con - where type excon = CompBasis.excon - where type lvar = CompBasis.lvar - where type StringTree = PrettyPrint.StringTree) - : COMPILE_BASIS = +structure CompileBasis : COMPILE_BASIS = struct structure PP = PrettyPrint @@ -52,20 +47,20 @@ functor CompileBasis(structure ClosExp : CLOS_EXP debug("clos_env", ClosExp_enrich(ce,ce')) end - fun match ((cb,ce),(cb0,ce0)) = - let val cb = CompBasis.match(cb,cb0) + fun match ((cb,ce),(cb0,ce0)) = + let val cb = CompBasis.match(cb,cb0) val _ = ClosExp.match(ce,ce0) in (cb,ce) end - fun restrict ((cb,ce),vars) = + fun restrict ((cb,ce),vars) = let val (cb1, lvars, cons, excons) = CompBasis.restrict(cb,vars) val ce1 = ClosExp.restrict(ce,{lvars=lvars,excons=excons,cons=cons}) in (cb1, ce1) end - fun restrict0 ((cb,ce),vars) = + fun restrict0 ((cb,ce),vars) = let (* Don't include identifiers that are declared by the initial basis *) val (cb1, lvars, cons, excons) = CompBasis.restrict0(cb,vars) val ce1 = ClosExp.restrict0(ce,{lvars=lvars,excons=excons,cons=cons}) @@ -75,7 +70,7 @@ functor CompileBasis(structure ClosExp : CLOS_EXP fun eq (B1,B2) = enrich(B1,B2) andalso enrich(B2,B1) val pu = - Pickle.pairGen(CompBasis.pu, + Pickle.pairGen(CompBasis.pu, Pickle.comment "ClosExp.pu" ClosExp.pu) end