1(* 2 Copyright (c) 2013, 2015, 2017, 2020 David C.J. Matthews 3 4 This library is free software; you can redistribute it and/or 5 modify it under the terms of the GNU Lesser General Public 6 License version 2.1 as published by the Free Software Foundation. 7 8 This library is distributed in the hope that it will be useful, 9 but WITHOUT ANY WARRANTY; without even the implied warranty of 10 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 11 Lesser General Public License for more details. 12 13 You should have received a copy of the GNU Lesser General Public 14 License along with this library; if not, write to the Free Software 15 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 16*) 17 18(* 19If a function has an empty closure it can be code-generated immediately. That may allow 20other functions or tuples to be generated immediately as well. As well as avoiding 21run-time allocations this also allows the code-generator to use calls/jumps to constant 22addresses. 23*) 24functor CODETREE_CODEGEN_CONSTANT_FUNCTIONS ( 25 structure BASECODETREE: BaseCodeTreeSig 26 structure CODETREE_FUNCTIONS: CodetreeFunctionsSig 27 structure BACKEND: CodegenTreeSig 28 structure DEBUG: DEBUG 29 structure PRETTY : PRETTYSIG 30 structure CODE_ARRAY: CODEARRAYSIG 31 32 sharing 33 BASECODETREE.Sharing 34 = CODETREE_FUNCTIONS.Sharing 35 = BACKEND.Sharing 36 = PRETTY.Sharing 37 = CODE_ARRAY.Sharing 38): 39sig 40 type codetree 41 type machineWord = Address.machineWord 42 val codeGenerate: codetree * int * Universal.universal list -> (unit -> machineWord) * Universal.universal list 43 structure Foreign: FOREIGNCALLSIG 44 structure Sharing: sig type codetree = codetree end 45end = 46struct 47 open BASECODETREE 48 open CODETREE_FUNCTIONS 49 open CODE_ARRAY 50 open Address 51 52 exception InternalError = Misc.InternalError 53 54 datatype lookupVal = EnvGenLoad of loadForm | EnvGenConst of machineWord * Universal.universal list 55 56 type cgContext = 57 { 58 lookupAddr: loadForm -> lookupVal, 59 enterConstant: int * (machineWord * Universal.universal list) -> unit, 60 debugArgs: Universal.universal list 61 } 62 63 (* Code-generate a function or set of mutually recursive functions that contain no free variables 64 and run the code to return the address. This allows us to further fold the address as 65 a constant if, for example, it is used in a tuple. *) 66 fun codeGenerateToConstant(lambda, debugSwitches, closure) = 67 let 68 val () = 69 if DEBUG.getParameter DEBUG.codetreeAfterOptTag debugSwitches 70 then PRETTY.getCompilerOutput debugSwitches (BASECODETREE.pretty(Lambda lambda)) else () 71 in 72 BACKEND.codeGenerate(lambda, debugSwitches, closure) 73 end 74 75 (* If we are code-generating a function immediately we make a one-word 76 mutable cell that will subsequently contain the address of the code. 77 After it is locked this becomes the closure of the function. By creating 78 it here we can turn recursive references into constant references before 79 we actually compile the function. *) 80 81 fun cgFuns ({ lookupAddr, ...}: cgContext) (Extract ext) = 82 ( 83 (* Look up the entry. It may now be a constant. If it isn't it may still 84 have changed if it is a closure entry and other closure entries have 85 been replaced by constants. *) 86 case lookupAddr ext of 87 EnvGenLoad load => SOME(Extract load) 88 | EnvGenConst w => SOME(Constnt w) 89 ) 90 91 | cgFuns (context as {debugArgs, ...}) (Lambda lambda) = 92 let 93 val copied as { closure=resultClosure, ...} = cgLambda(context, lambda, EnvGenLoad LoadRecursive) 94 in 95 case resultClosure of 96 [] => 97 let 98 (* Create a "closure" for the function. *) 99 val closure = makeConstantClosure() 100 (* Replace any recursive references by references to the closure. There 101 may be inner functions that only make recursive calls to this. By turning 102 the recursive references into constants we may be able to compile 103 them immediately as well. *) 104 val repLambda = cgLambda(context, lambda, EnvGenConst(toMachineWord closure, [])) 105 val props = codeGenerateToConstant(repLambda, debugArgs, closure) 106 in 107 SOME(Constnt(toMachineWord closure, props)) 108 end 109 | _ => SOME(Lambda copied) 110 end 111 112 | cgFuns (context as { enterConstant, debugArgs, ...}) (Newenv(envBindings, envExp)) = 113 let 114 (* First expand out any mutually-recursive bindings. This ensures that if 115 we have any RecDecs left *) 116 val expandedBindings = 117 List.foldr (fn (d, l) => partitionMutualBindings d @ l) [] envBindings 118 119 fun processBindings(Declar{value, addr, use} :: tail) = 120 ( 121 (* If this is a constant put it in the table otherwise create a binding. *) 122 case mapCodetree (cgFuns context) value of 123 Constnt w => (enterConstant(addr, w); processBindings tail) 124 | code => Declar{value=code, addr=addr, use=use} :: processBindings tail 125 ) 126 127 | processBindings(NullBinding c :: tail) = 128 NullBinding(mapCodetree (cgFuns context) c) :: processBindings tail 129 130 | processBindings(RecDecs[{addr, lambda, use}] :: tail) = 131 (* Single recursive bindings - treat as simple binding *) 132 processBindings(Declar{addr=addr, value=Lambda lambda, use = use} :: tail) 133 134 | processBindings(RecDecs recdecs :: tail) = 135 let 136 (* We know that this forms a strongly connected component so it is only 137 possible to code-generate the group if no function has a free-variable 138 outside the group. Each function must have at least one free 139 variable which is part of the group. *) 140 fun processEntry {addr, lambda, use} = 141 {addr=addr, lambda=cgLambda(context, lambda, EnvGenLoad LoadRecursive), use=use} 142 val processedGroup = map processEntry recdecs 143 144 (* If every free variable is another member of the group we can 145 code-generate the group. *) 146 local 147 fun closureItemInGroup(LoadLocal n) = 148 List.exists(fn{addr, ...} => n = addr) processedGroup 149 | closureItemInGroup _ = false 150 151 fun onlyInGroup{lambda={closure, ...}, ...} = List.all closureItemInGroup closure 152 in 153 val canCodeGen = List.all onlyInGroup processedGroup 154 end 155 in 156 if canCodeGen 157 then 158 let 159 open Address 160 (* Create "closures" for each entry. Add these as constants to the table. *) 161 fun createAndEnter {addr, ...} = 162 let val c = makeConstantClosure() in enterConstant(addr, (Address.toMachineWord c, [])); c end 163 val closures = List.map createAndEnter processedGroup 164 (* Code-generate each of the lambdas and store the code in the closure. *) 165 fun processLambda({lambda, addr, ...}, closure) = 166 let 167 val closureAsMachineWord = Address.toMachineWord closure 168 val repLambda = 169 cgLambda(context, lambda, EnvGenConst(closureAsMachineWord, [])) 170 val props = codeGenerateToConstant(repLambda, debugArgs, closure) 171 in 172 (* Include any properties we may have added *) 173 enterConstant(addr, (closureAsMachineWord, props)) 174 end 175 val () = ListPair.appEq processLambda (processedGroup, closures) 176 in 177 processBindings tail (* We've done these *) 178 end 179 180 else RecDecs processedGroup :: processBindings tail 181 end 182 183 | processBindings(Container{addr, use, size, setter} :: tail) = 184 Container{addr=addr, use=use, size=size, 185 setter = mapCodetree (cgFuns context) setter} :: processBindings tail 186 187 | processBindings [] = [] 188 189 val bindings = processBindings expandedBindings 190 val body = mapCodetree (cgFuns context) envExp 191 in 192 case bindings of 193 [] => SOME body 194 | _ => SOME(Newenv(bindings, body)) 195 end 196 197 | cgFuns context (Tuple{ fields, isVariant }) = 198 (* Create any constant tuples that have arisen because they contain 199 constant functions. *) 200 SOME((if isVariant then mkDatatype else mkTuple)(map (mapCodetree (cgFuns context)) fields)) 201 202 | cgFuns _ _ = NONE 203 204 and cgLambda({lookupAddr, debugArgs, ...}, 205 { body, isInline, name, closure, argTypes, resultType, localCount, recUse}, 206 loadRecursive) = 207 let 208 val cArray = Array.array(localCount, NONE) 209 val newClosure = makeClosure() 210 211 fun lookupLocal(load as LoadLocal n) = 212 ( 213 case Array.sub(cArray, n) of 214 NONE => EnvGenLoad load 215 | SOME w => EnvGenConst w 216 ) 217 | lookupLocal(LoadClosure n) = 218 ( 219 case lookupAddr(List.nth (closure, n)) of 220 EnvGenLoad load => EnvGenLoad(addToClosure newClosure load) 221 | c as EnvGenConst _ => c 222 ) 223 | lookupLocal LoadRecursive = loadRecursive 224 | lookupLocal load = EnvGenLoad load (* Argument *) 225 226 val context = 227 { 228 lookupAddr = lookupLocal, 229 enterConstant = fn (n, w) => Array.update(cArray, n, SOME w), 230 debugArgs = debugArgs 231 } 232 233 (* Process the body to deal with any sub-functions and also to bind 234 in any constants from free variables. *) 235 val newBody = mapCodetree (cgFuns context) body 236 (* Build the resulting lambda. *) 237 val resultClosure = extractClosure newClosure 238 in 239 { 240 body = newBody, isInline = isInline, name = name, closure = resultClosure, 241 argTypes = argTypes, resultType = resultType, localCount = localCount, 242 recUse = recUse 243 } 244 end 245 246 fun codeGenerate(original, nLocals, debugArgs) = 247 let 248 val cArray = Array.array(nLocals, NONE) 249 fun lookupAddr(load as LoadLocal n) = 250 ( 251 case Array.sub(cArray, n) of 252 NONE => EnvGenLoad load 253 | SOME w => EnvGenConst w 254 ) 255 | lookupAddr _ = raise InternalError "lookupConstant: top-level reached" 256 257 val context = 258 { 259 lookupAddr = lookupAddr, 260 enterConstant = fn (n, w) => Array.update(cArray, n, SOME w), 261 debugArgs = debugArgs 262 } 263 264 val resultCode = mapCodetree (cgFuns context) original 265 (* Turn this into a lambda to code-generate. *) 266 val lambda:lambdaForm = 267 { 268 body = resultCode, 269 isInline = DontInline, 270 name = "<top level>", 271 closure = [], 272 argTypes = [(GeneralType, [])], 273 resultType = GeneralType, 274 localCount = nLocals, 275 recUse = [] 276 } 277 val closure = makeConstantClosure() 278 279 val props = BACKEND.codeGenerate(lambda, debugArgs, closure) 280 281 (* The code may consist of tuples (i.e. compiled ML structures) containing 282 a mixture of Loads, where the values are yet to be compiled, and 283 Constants, where the code has now been compiled. We need to extract 284 any properties from the constants and return the whole lot as 285 tuple properties. *) 286 fun extractProps(Constnt(_, p)) = p 287 | extractProps(Extract ext) = 288 ( 289 case lookupAddr ext of 290 EnvGenLoad _ => [] 291 | EnvGenConst(_, p) => p 292 ) 293 | extractProps(Tuple{fields, ...}) = 294 let 295 val fieldProps = map extractProps fields 296 in 297 if List.all null fieldProps 298 then [] 299 else [Universal.tagInject CodeTags.tupleTag fieldProps] 300 end 301 | extractProps(Newenv(_, exp)) = extractProps exp 302 | extractProps _ = [] 303 304 val newProps = extractProps original 305 (* Cast this as a function. It is a function with a single argument. *) 306 val resultFunction: unit -> machineWord = RunCall.unsafeCast closure 307 308 in 309 (resultFunction, CodeTags.mergeTupleProps(newProps, props)) 310 end 311 312 structure Foreign = BACKEND.Foreign 313 314 structure Sharing = struct type codetree = codetree end 315end; 316