Native backend refactorisation

.github/workflows/main.yml

@@ -70,7 +70,12 @@ jobs:
           /usr/local/bin/gcc-14 --version
           brew install autoconf make
           brew tap homebrew/cask
-          brew install --cask phantomjs
+          mkdir phantomjs
+          cd phantomjs
+          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 ..
 
       - name: Install dependencies (macos, mlton)
         if: ${{ env.OS == 'darwin' && matrix.mlcomp == 'mlton' }}
@@ -84,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

Makefile.in

@@ -291,7 +291,7 @@ install_src:
 	$(INSTALLDATA) src/Compiler/*.{mlb,sig,sml} $(INSTDIR)/src/Compiler
 	$(INSTALLDATA) src/Compiler/Lambda/*.{sig,sml} $(INSTDIR)/src/Compiler/Lambda
 	$(INSTALLDATA) src/Compiler/Regions/*.{sig,sml} $(INSTDIR)/src/Compiler/Regions
-	$(INSTALLDATA) src/Compiler/Backend/*.sml $(INSTDIR)/src/Compiler/Backend
+	$(INSTALLDATA) src/Compiler/Backend/*.{sig,sml} $(INSTDIR)/src/Compiler/Backend
 	$(INSTALLDATA) src/Compiler/Backend/Barry/*.sml $(INSTDIR)/src/Compiler/Backend/Barry
 	$(INSTALLDATA) src/Compiler/Backend/Dummy/*.sml $(INSTDIR)/src/Compiler/Backend/Dummy
 	$(INSTALLDATA) src/Compiler/Backend/X64/*.sml $(INSTDIR)/src/Compiler/Backend/X64
@@ -320,11 +320,11 @@ bootstrap_first:
 	$(MAKE) bootstrap0
 
 MLKIT_FLAGS ?=
-MLKIT_BUILD_LOG ?= native64.log
+MLKIT_BUILD_LOG ?= mlkit64.log
 
 .PHONY: bootstrap_next_build
 bootstrap_next_build:
-	cd src/Compiler && SML_LIB=$(CWD) $(TIMECMD) ../../bin/mlkit $(MLKIT_FLAGS) -gc native64.mlb \
+	cd src/Compiler && SML_LIB=$(CWD) $(TIMECMD) ../../bin/mlkit $(MLKIT_FLAGS) -gc mlkit64.mlb \
              2>&1 | tee $(MLKIT_BUILD_LOG)
 
 .PHONY: bootstrap_next_install

src/Compiler/Backend/BACKEND_INFO.sml

@@ -15,25 +15,25 @@ signature BACKEND_INFO =
     val ml_false : int (* The representation of false *)
     val ml_unit  : int (* The representation of unit *)
 
-    val pr_tag_w : Word32.word -> string
+    val pr_tag_w : word -> string
     val pr_tag_i : int -> string
 
-    val tag_real       : bool -> Word32.word
-    val tag_word_boxed : bool -> Word32.word
-    val tag_string     : bool * int -> Word32.word
-    val tag_record     : bool * int -> Word32.word
-    val tag_blockf64   : bool * int -> Word32.word
-    val tag_con0       : bool * int -> Word32.word
-    val tag_con1       : bool * int -> Word32.word
-    val tag_ref        : bool -> Word32.word
-    val tag_clos       : bool * int * int -> Word32.word
-    val tag_sclos      : bool * int * int -> Word32.word
-    val tag_regvec     : bool * int -> Word32.word
-    val tag_table      : bool * int -> Word32.word
-    val tag_exname     : bool -> Word32.word
-    val tag_excon0     : bool -> Word32.word
-    val tag_excon1     : bool -> Word32.word
-    val tag_ignore     : Word32.word
+    val tag_real       : bool -> word
+    val tag_word_boxed : bool -> word
+    val tag_string     : bool * int -> word
+    val tag_record     : bool * int -> word
+    val tag_blockf64   : bool * int -> word
+    val tag_con0       : bool * int -> word
+    val tag_con1       : bool * int -> word
+    val tag_ref        : bool -> word
+    val tag_clos       : bool * int * int -> word
+    val tag_sclos      : bool * int * int -> word
+    val tag_regvec     : bool * int -> word
+    val tag_table      : bool * int -> word
+    val tag_exname     : bool -> word
+    val tag_excon0     : bool -> word
+    val tag_excon1     : bool -> word
+    val tag_ignore     : word
 
     val inf_bit          : int (* We must add 1 to an address to set the infinite bit. *)
     val atbot_bit        : int (* We must add 2 to an address to set the atbot bit. *)
@@ -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

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
@@ -15,22 +15,22 @@ functor BackendInfo(val down_growing_stack : bool) : BACKEND_INFO =
     (* Tagging *)
     (***********)
 
-    fun pr_tag_w tag = "0X" ^ (Word32.fmt StringCvt.HEX tag)
+    fun pr_tag_w tag = "0X" ^ (Word.fmt StringCvt.HEX tag)
     (* For now, some tags are in integers but it should be eliminated; max size is
        then 2047 only 09/01/1999, Niels *)
     fun pr_tag_i tag = "0X" ^ (Int.fmt StringCvt.HEX tag)
 
-    fun pw (s,w) = print (s ^ " is " ^ (Word32.fmt StringCvt.BIN w) ^ "\n")
-    fun or_bits (w1,w2) = Word32.orb(w1,w2)
-    fun shift_left (num_bits,w) = Word32.<<(w,Word.fromInt num_bits)
+    fun pw (s,w) = print (s ^ " is " ^ (Word.fmt StringCvt.BIN w) ^ "\n")
+    fun or_bits (w1,w2) = Word.orb(w1,w2)
+    fun shift_left (num_bits,w) = Word.<<(w,Word.fromInt num_bits)
 
     (* off is the offset at which values are traversed *)
     fun gen_record_tag (s:int,off:int,i:bool,t:int) =
       let
-	val size = Word32.fromInt s
-	val offset = Word32.fromInt off
-	val immovable = if i then Word32.fromInt 1 else Word32.fromInt 0
-	val tag = Word32.fromInt t
+	val size = Word.fromInt s
+	val offset = Word.fromInt off
+	val immovable = if i then Word.fromInt 1 else Word.fromInt 0
+	val tag = Word.fromInt t
 	val w_size = shift_left(19,size)
 	val w_offset = or_bits(w_size,shift_left(6,offset))
 	val w_immovable = or_bits(w_offset,shift_left(5,immovable))
@@ -41,9 +41,9 @@ functor BackendInfo(val down_growing_stack : bool) : BACKEND_INFO =
 
     fun gen_string_tag (s:int,i:bool,t:int) =
       let
-	val size = Word32.fromInt s
-	val immovable = if i then Word32.fromInt 1 else Word32.fromInt 0
-	val tag = Word32.fromInt t
+	val size = Word.fromInt s
+	val immovable = if i then Word.fromInt 1 else Word.fromInt 0
+	val tag = Word.fromInt t
 	val w_size = shift_left(6,size)
 	val w_immovable = or_bits(w_size,shift_left(5,immovable))
 	val w_tag = or_bits(w_immovable,tag)
@@ -70,7 +70,7 @@ functor BackendInfo(val down_growing_stack : bool) : BACKEND_INFO =
     fun tag_exname (i:bool)            = gen_record_tag(2,2,i,6)
     fun tag_excon0 (i:bool)            = gen_record_tag(1,0,i,6)
     fun tag_excon1 (i:bool)            = gen_record_tag(2,0,i,6)
-    val tag_ignore                     = Word32.fromInt 0
+    val tag_ignore                     = Word.fromInt 0
 
     val inf_bit           = 1   (* We add 1 to an address to set the infinite bit. *)
     val atbot_bit         = 2   (* We add 2 to an address to set the atbot bit. *)
@@ -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

src/Compiler/Backend/CLOS_EXP.sml

@@ -67,11 +67,10 @@ signature CLOS_EXP =
     | PASS_PTR_TO_RHO of {sma: sma}
     | UB_RECORD       of ClosExp list
     | CLOS_RECORD     of {label: label, elems: ClosExp list * ClosExp list * ClosExp list, f64_vars: int, alloc: sma}
-    | REGVEC_RECORD   of {elems: sma list, alloc: sma}
     | SCLOS_RECORD    of {elems: ClosExp list * ClosExp list * ClosExp list, f64_vars: int, alloc: sma}
-    | RECORD          of {elems: ClosExp list, alloc: sma, tag: Word32.word, maybeuntag: bool}
-    | BLOCKF64        of {elems: ClosExp list, alloc: sma, tag: Word32.word}
-    | SCRATCHMEM      of {bytes: int, alloc: sma, tag: Word32.word}
+    | RECORD          of {elems: ClosExp list, alloc: sma, tag: word, maybeuntag: bool}
+    | BLOCKF64        of {elems: ClosExp list, alloc: sma, tag: word}
+    | SCRATCHMEM      of {bytes: int, alloc: sma, tag: word}
     | SELECT          of int * ClosExp
     | FNJMP           of {opr: ClosExp, args: ClosExp list, clos: ClosExp option}
     | FNCALL          of {opr: ClosExp, args: ClosExp list, clos: ClosExp option}

src/Compiler/Backend/CalcOffset.sml

@@ -1,21 +1,20 @@
-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
 		       where type place = Effect.effect
 		       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

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)

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

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
@@ -75,11 +67,10 @@ struct
     | PASS_PTR_TO_RHO of {sma:sma}
     | UB_RECORD       of ClosExp list
     | CLOS_RECORD     of {label: label, elems: ClosExp list * ClosExp list * ClosExp list, f64_vars: int, alloc: sma}
-    | REGVEC_RECORD   of {elems: sma list, alloc: sma}
     | SCLOS_RECORD    of {elems: ClosExp list * ClosExp list * ClosExp list, f64_vars: int, alloc: sma}
-    | RECORD          of {elems: ClosExp list, alloc: sma, tag: Word32.word, maybeuntag: bool}
-    | BLOCKF64        of {elems: ClosExp list, alloc: sma, tag: Word32.word}
-    | SCRATCHMEM      of {bytes:int, alloc: sma, tag: Word32.word}
+    | RECORD          of {elems: ClosExp list, alloc: sma, tag: word, maybeuntag: bool}
+    | BLOCKF64        of {elems: ClosExp list, alloc: sma, tag: word}
+    | SCRATCHMEM      of {bytes:int, alloc: sma, tag: word}
     | SELECT          of int * ClosExp
     | FNJMP           of {opr: ClosExp, args: ClosExp list, clos: ClosExp option}
     | FNCALL          of {opr: ClosExp, args: ClosExp list, clos: ClosExp option}
@@ -211,10 +202,6 @@ struct
               childsep=RIGHT ",",
               children=LEAF(Labels.pr_label label)::
                        map layout_ce (rhos@excons@lvs)}
-      | layout_ce(REGVEC_RECORD{elems,alloc}) = HNODE{start="[",
-                                                      finish="]regvec " ^ (flatten1(pr_sma alloc)),
-                                                      childsep=RIGHT ",",
-                                                      children=map (fn sma => pr_sma sma) elems}
       | layout_ce(SCLOS_RECORD{elems=(lvs,excons,rhos),f64_vars,alloc}) =
         HNODE{start="[",
               finish="]sclos(" ^ Int.toString f64_vars ^ ") " ^ (flatten1(pr_sma alloc)),
@@ -2000,8 +1987,8 @@ struct
                     | CE.UB_UNARY i => (con,UNBOXED i)
                     | CE.UBH_NULLARY i => (con,UNBOXED_HIGH i)
                     | CE.UBH_UNARY i => (con,UNBOXED_HIGH i)
-                    | CE.B_NULLARY i => (con,BOXED(Word32.toInt (BI.tag_con0(false,i))))
-                    | CE.B_UNARY i => (con,BOXED(Word32.toInt (BI.tag_con1(false,i)))))
+                    | CE.B_NULLARY i => (con,BOXED(Word.toInt (BI.tag_con0(false,i))))
+                    | CE.B_UNARY i => (con,BOXED(Word.toInt (BI.tag_con1(false,i)))))
 
                  val (selections,opt) =
                    compile_sels_and_default selections opt tag