1(* 2 Copyright (c) 2000 3 Cambridge University Technical Services Limited 4 5 Modified David C.J. Matthews 2008-9, 2015-16, 2020. 6 7 This library is free software; you can redistribute it and/or 8 modify it under the terms of the GNU Lesser General Public 9 License version 2.1 as published by the Free Software Foundation 10 11 This library is distributed in the hope that it will be useful, 12 but WITHOUT ANY WARRANTY; without even the implied warranty of 13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 Lesser General Public License for more details. 15 16 You should have received a copy of the GNU Lesser General Public 17 License along with this library; if not, write to the Free Software 18 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 19*) 20 21(* 22 Title: Poly Make Program. 23 Author: Dave Matthews, Cambridge University Computer Laboratory 24 Copyright Cambridge University 1985 25*) 26 27(* This previously contained PolyML.make which was passed through to 28 the basis. It has now been reduced to just "use" and is 29 only used during the bootstrap process to compile the basis 30 library itself. *) 31 32functor MAKE_ ( 33 34structure COMPILERBODY : COMPILERBODYSIG 35 36structure UNIVERSALTABLE : 37sig 38 type 'a tag = 'a Universal.tag; 39 type univTable; 40 type universal = Universal.universal 41 42 val makeUnivTable: unit -> univTable 43 val univEnter: univTable * 'a tag * string * 'a -> unit; 44 val univLookup: univTable * 'a tag * string -> 'a option; 45 val univDelete: univTable * 'a tag * string -> unit; 46 val fold: (string * universal * 'a -> 'a) -> 'a -> univTable -> 'a 47end; 48 49structure STRUCTVALS : STRUCTVALSIG; 50structure DEBUG: DEBUG 51structure PRETTY: PRETTYSIG (* For compilerOutputTag *) 52structure LEX: LEXSIG (* For errorMessageProcTag *) 53 54structure VERSION: 55 sig 56 val versionSuffix: string 57 end 58 59sharing STRUCTVALS.Sharing = COMPILERBODY.Sharing 60sharing LEX.Sharing = PRETTY.Sharing 61 62) : MAKESIG = 63 64struct 65 type univTable = UNIVERSALTABLE.univTable; 66 type values = STRUCTVALS.values 67 type typeConstrs = STRUCTVALS.typeConstrs 68 type fixStatus = STRUCTVALS.fixStatus 69 type structVals = STRUCTVALS.structVals 70 type signatures = STRUCTVALS.signatures 71 type functors = STRUCTVALS.functors 72 type env = STRUCTVALS.env 73 74 open COMPILERBODY 75 76 local 77 open UNIVERSALTABLE 78 open Thread.Thread 79 open Thread.Mutex 80 in 81 (* Create an environment with a mutex to protect concurrent access. *) 82 datatype gEnv = DbEnv of mutex * univTable 83 84 (* Lock the mutex during any lookup or entry. This is primarily to 85 avoid the underlying hash table from being rehashed by different 86 threads at the same time. This code should be in a library. *) 87 fun protect mutx f = 88 let 89 (* Turn off interrupts while we have the lock. *) 90 val oldAttrs = getAttributes() 91 val () = setAttributes[InterruptState InterruptDefer] 92 val () = lock mutx 93 val result = f() 94 handle exn => (unlock mutx; setAttributes oldAttrs; raise exn) 95 in 96 unlock mutx; 97 setAttributes oldAttrs; 98 result 99 end 100 101 (* Create an environment *) 102 fun makeGEnv () : gEnv = DbEnv (mutex(), makeUnivTable()); 103 104 (* enter a value into an environment *) 105 fun dbEnvEnter (DbEnv(mutx, db)) (t : 'a tag) (s : string, v : 'a) : unit = 106 protect mutx (fn () => univEnter (db, t, s, v)) 107 108 (* find a value in an environment *) 109 fun dbEnvLookup (DbEnv(mutx, db)) (t : 'a tag) (s : string) : 'a option = 110 protect mutx(fn () => univLookup (db, t, s)) 111 112 fun dbEnvAll (DbEnv(mutx, db)) (t : 'a tag) () : (string * 'a) list = 113 let 114 open Universal UNIVERSALTABLE 115 fun filter (s, c, l) = if tagIs t c then (s, tagProject t c) :: l else l 116 in 117 protect mutx (fn () => fold filter [] db) 118 end 119 120 fun gEnvAsEnv gEnv = 121 STRUCTVALS.Env { 122 lookupFix = dbEnvLookup gEnv STRUCTVALS.fixVar, 123 lookupVal = dbEnvLookup gEnv STRUCTVALS.valueVar, 124 lookupType = dbEnvLookup gEnv STRUCTVALS.typeConstrVar, 125 lookupSig = dbEnvLookup gEnv STRUCTVALS.signatureVar, 126 lookupStruct = dbEnvLookup gEnv STRUCTVALS.structVar, 127 lookupFunct = dbEnvLookup gEnv STRUCTVALS.functorVar, 128 129 enterFix = dbEnvEnter gEnv STRUCTVALS.fixVar, 130 enterVal = dbEnvEnter gEnv STRUCTVALS.valueVar, 131 enterType = dbEnvEnter gEnv STRUCTVALS.typeConstrVar, 132 enterSig = dbEnvEnter gEnv STRUCTVALS.signatureVar, 133 enterStruct = dbEnvEnter gEnv STRUCTVALS.structVar, 134 enterFunct = dbEnvEnter gEnv STRUCTVALS.functorVar, 135 136 allValNames = 137 fn () => map #1 (dbEnvAll gEnv STRUCTVALS.valueVar ()) 138 }; 139 140 fun gEnvAsNameSpace gEnv: nameSpace = 141 { 142 lookupFix = dbEnvLookup gEnv STRUCTVALS.fixVar, 143 lookupVal = dbEnvLookup gEnv STRUCTVALS.valueVar, 144 lookupType = dbEnvLookup gEnv STRUCTVALS.typeConstrVar, 145 lookupSig = dbEnvLookup gEnv STRUCTVALS.signatureVar, 146 lookupStruct = dbEnvLookup gEnv STRUCTVALS.structVar, 147 lookupFunct = dbEnvLookup gEnv STRUCTVALS.functorVar, 148 149 enterFix = dbEnvEnter gEnv STRUCTVALS.fixVar, 150 enterVal = dbEnvEnter gEnv STRUCTVALS.valueVar, 151 enterType = dbEnvEnter gEnv STRUCTVALS.typeConstrVar, 152 enterSig = dbEnvEnter gEnv STRUCTVALS.signatureVar, 153 enterStruct = dbEnvEnter gEnv STRUCTVALS.structVar, 154 enterFunct = dbEnvEnter gEnv STRUCTVALS.functorVar, 155 156 allFix = dbEnvAll gEnv STRUCTVALS.fixVar, 157 allVal = dbEnvAll gEnv STRUCTVALS.valueVar, 158 allType = dbEnvAll gEnv STRUCTVALS.typeConstrVar, 159 allSig = dbEnvAll gEnv STRUCTVALS.signatureVar, 160 allStruct = dbEnvAll gEnv STRUCTVALS.structVar, 161 allFunct = dbEnvAll gEnv STRUCTVALS.functorVar 162 }; 163 164 end; 165 166 (*****************************************************************************) 167 (* useIntoEnv (runcompiler with ML compiler bound in) *) 168 (*****************************************************************************) 169 fun compileIntoEnv (globalEnv : gEnv) : (string * TextIO.instream * Universal.universal list) -> unit = 170 let 171 val useEnv : nameSpace = 172 { 173 lookupFix = dbEnvLookup globalEnv STRUCTVALS.fixVar, 174 lookupVal = dbEnvLookup globalEnv STRUCTVALS.valueVar, 175 lookupType = dbEnvLookup globalEnv STRUCTVALS.typeConstrVar, 176 lookupSig = dbEnvLookup globalEnv STRUCTVALS.signatureVar, 177 lookupStruct = dbEnvLookup globalEnv STRUCTVALS.structVar, 178 lookupFunct = dbEnvLookup globalEnv STRUCTVALS.functorVar, 179 enterFix = dbEnvEnter globalEnv STRUCTVALS.fixVar, 180 enterVal = dbEnvEnter globalEnv STRUCTVALS.valueVar, 181 enterType = dbEnvEnter globalEnv STRUCTVALS.typeConstrVar, 182 enterStruct = dbEnvEnter globalEnv STRUCTVALS.structVar, 183 enterSig = dbEnvEnter globalEnv STRUCTVALS.signatureVar, 184 enterFunct = dbEnvEnter globalEnv STRUCTVALS.functorVar, 185 allFix = dbEnvAll globalEnv STRUCTVALS.fixVar, 186 allVal = dbEnvAll globalEnv STRUCTVALS.valueVar, 187 allType = dbEnvAll globalEnv STRUCTVALS.typeConstrVar, 188 allSig = dbEnvAll globalEnv STRUCTVALS.signatureVar, 189 allStruct = dbEnvAll globalEnv STRUCTVALS.structVar, 190 allFunct = dbEnvAll globalEnv STRUCTVALS.functorVar 191 }; 192 193 fun use (fileName, inStream, parameters) = 194 let 195 val lineNo = ref 1; 196 val eof = ref false; 197 198 fun getChar () : char option = 199 case TextIO.input1 inStream of 200 eoln as SOME #"\n" => 201 ( 202 lineNo := !lineNo + 1; 203 eoln 204 ) 205 | NONE => (eof := true; NONE) 206 | c => c 207 208 fun errorProc {message, hard, location={ file, startLine=line, ... }, ...} = 209 TextIO.print(concat 210 [if hard then "Error-" else "Warning-", 211 " in '", file, "', line ", FixedInt.toString line, ".\n", 212 PRETTY.uglyPrint message, "\n"]) 213 in 214 ( 215 while not (! eof) do 216 let 217 open DEBUG Universal 218 219 (* Compile the code *) 220 val code = 221 case COMPILERBODY.compiler 222 (useEnv, getChar, 223 parameters @ (* These will be found first and override the defaults. *) 224 [ 225 tagInject PRETTY.compilerOutputTag (PRETTY.prettyPrint(print, 70)), 226 tagInject lineNumberTag (fn () => !lineNo), 227 tagInject fileNameTag fileName, 228 tagInject LEX.errorMessageProcTag errorProc, 229 tagInject maxInlineSizeTag 80, 230 tagInject reportUnreferencedIdsTag true, 231 tagInject reportExhaustiveHandlersTag false, (* True for testing. *) 232 (* These are only needed for debugging. *) 233 tagInject PRETTY.printOutputTag (PRETTY.prettyPrint(print, 70)), 234 tagInject printDepthFunTag(fn () => 20), 235 tagInject parsetreeTag false, 236 tagInject codetreeTag false, 237 tagInject codetreeAfterOptTag false, 238 tagInject icodeTag false, 239 tagInject assemblyCodeTag false 240 ] ) of 241 (_, NONE) => raise Fail "Static Errors" 242 | (_, SOME c) => c 243 (* execute the code and get the resulting declarations. *) 244 val { fixes, values, structures, signatures, functors, types } = code() 245 in 246 (* Just enter the values in the environment without printing. *) 247 List.app (#enterFix useEnv) fixes; 248 List.app (#enterVal useEnv) values; 249 List.app (#enterStruct useEnv) structures; 250 List.app (#enterSig useEnv) signatures; 251 List.app (#enterFunct useEnv) functors; 252 List.app (#enterType useEnv) types 253 end 254 ) 255 handle Fail s => (* E.g. syntax error. *) 256 ( 257 TextIO.closeIn inStream; 258 raise Fail s 259 ) 260 | exn => (* close inStream if an error occurs *) 261 ( 262 print ("Exception- " ^ General.exnName exn ^ " raised\n"); 263 TextIO.closeIn inStream; 264 raise exn 265 ) 266 end (* use *) 267 in 268 use 269 end; (* scope of compileIntoEnv *) 270 271 fun useIntoEnv globalEnv parameters baseName = 272 let 273 val () = print ("Use: " ^ baseName ^ "\n") 274 (* See if there is a path given as a command line argument. *) 275 val args = CommandLine.arguments(); 276 (* If we have -I filename use that as the output name. 277 N.B. polyImport takes the first argument that is not recognised as 278 an RTS argument and treats that as the file name so any -I must occur 279 AFTER the import file. *) 280 fun getPath [] = "." (* Default path *) 281 | getPath ("-I" :: path :: _) = path 282 | getPath (_::tl) = getPath tl 283 open OS.Path 284 (* Add the path to the source on to the directory. *) 285 val filePath = concat(getPath args, baseName) 286 open VERSION 287 (* See if we have a version of the file specific to this 288 version of the compiler. For x.ML see if x.VER.ML exists. 289 When bootstrapping from one version of the compiler to 290 another we need to compile the basis library in both the 291 old and new compiler. If the interface has changed we may 292 need version-specific files. *) 293 val { base, ext } = splitBaseExt filePath 294 val versionName = 295 joinBaseExt { 296 base = joinBaseExt{base = base, ext = SOME versionSuffix}, 297 ext = ext } 298 val (inStream, fileName) = 299 (TextIO.openIn versionName, versionName) 300 handle IO.Io _ => (TextIO.openIn filePath, filePath) 301 in 302 compileIntoEnv globalEnv (fileName, inStream, parameters); 303 TextIO.closeIn inStream 304 end 305 306 fun shellProc globalEnv () = compileIntoEnv globalEnv ("<stdin>", TextIO.stdIn, []) 307 308 fun useStringIntoEnv globalEnv str = 309 compileIntoEnv globalEnv (str, TextIO.openString str, []) 310 311 structure Sharing = 312 struct 313 type env = env 314 type gEnv = gEnv 315 type values = values 316 type typeConstrSet = typeConstrSet 317 type fixStatus = fixStatus 318 type structVals = structVals 319 type signatures = signatures 320 type functors = functors 321 type ptProperties = ptProperties 322 end 323end; 324 325 326 327