Return to moduleComp.sml CVS log

Up to [Research Unix] / researchv10no / cmd / sml / src / sepcomp

Annotation of researchv10no/cmd/sml/src/sepcomp/moduleComp.sml, revision 1.1

1.1     ! root        1: (* Copyright 1989 by AT&T Bell Laboratories *)
        !             2: (* moduleComp.sml *)
        !             3: (* Modules compiler for New Jersey ML.   Nick Rothwell, LFCS, January 1989. *)
        !             4: (* New version, doing proper lambda nesting for declarations and imports,
        !             5:    rather than the old clatty concatenation stuff. *)
        !             6: 
        !             7: functor ModuleComp(structure Absyn: BAREABSYN
        !             8:                     sharing Absyn = BareAbsyn
        !             9:                   structure Lambda: LAMBDA
        !            10:                   structure Opt: OPT sharing Opt.L = Lambda
        !            11:                   structure Machm: CODEGENERATOR
        !            12:                  ): MODULE_COMPILER =
        !            13:   struct
        !            14:     structure Lambda = Lambda
        !            15:     structure Absyn = Absyn
        !            16: 
        !            17:     val bug = ErrorMsg.impossible
        !            18: 
        !            19:      (* Warning:  if DEBUG is true, then exportFn tends to grab the whole
        !            20:         compiler.   --Appel *)
        !            21:     val DEBUG = false
        !            22: 
        !            23:     type lvar = Access.lvar
        !            24:     type lexp = Lambda.lexp
        !            25:     type code = string
        !            26: 
        !            27:     fun assert(msg, cond) =
        !            28:       if cond then () else bug("assert: " ^ msg)
        !            29: 
        !            30:     fun pr s = (output std_out s; flush_out std_out)
        !            31: 
        !            32:     fun debug s = if DEBUG then pr s else ()
        !            33: 
        !            34: 
        !            35:     abstype LambDynModule =
        !            36:            LAMBDYNMODULE of {entry: Entry, lvars: lvar list} list
        !            37:                        (* These are in reverse order of declaration. *)
        !            38:        and CodeDynModule =
        !            39:            CODEDYNMODULE of {self: code, subModules: CodeDynModule list}
        !            40:                        (* The code is for a function:
        !            41:                           "(M1, ..., Mn) -> looker -> array*rubbish"
        !            42:                           where each Mi is a "looker -> array*rubbish" *)
        !            43: 
        !            44:        and Entry = LAMBDAentry of lexp->lexp           (* unclosed *)
        !            45:                  | IMPORTentry of CodeDynModule
        !            46:     with
        !            47:       val emptyDynModule = LAMBDYNMODULE []
        !            48: 
        !            49:       exception AddDeclaration
        !            50:       fun addDeclaration(dec, lvars, LAMBDYNMODULE entries) =
        !            51:         let
        !            52:          val newEntry =
        !            53:            {entry=LAMBDAentry(Translate.transDec dec), lvars=rev lvars}
        !            54:         in
        !            55:          if !ErrorMsg.anyErrors then
        !            56:            raise AddDeclaration
        !            57:          else
        !            58:            LAMBDYNMODULE(newEntry :: entries)
        !            59:        end
        !            60: 
        !            61:       fun importDynModule(LAMBDYNMODULE inner, LAMBDYNMODULE outer) =
        !            62:         LAMBDYNMODULE(inner @ outer)
        !            63: 
        !            64:       fun abstractDynModule(codeDynModule, lvars) =
        !            65:         LAMBDYNMODULE [{entry=IMPORTentry codeDynModule, lvars=lvars}]
        !            66: 
        !            67:      (* compiler: takes a LambDynModule to a CodeDynModule. We tie together
        !            68:         all the lambdas as a set of nested LET declarations. Where we import
        !            69:        already-compiled modules, these are abstracted to be arguments to the
        !            70:        final lambda expression. *)
        !            71: 
        !            72:       fun inventLvar name =
        !            73:         let
        !            74:          val saving = !System.Control.saveLvarNames
        !            75:          val _ = (System.Control.saveLvarNames := true)
        !            76:          val lvar = Access.namedLvar(Symbol.symbol(name ^ ":"))
        !            77:          val _ = (System.Control.saveLvarNames := saving)
        !            78:        in
        !            79:          lvar
        !            80:        end
        !            81: 
        !            82:      (* Some local lambda-building stuff. This should probably go in a wee
        !            83:         structure of its own. *)
        !            84: 
        !            85:       local
        !            86:         open Lambda
        !            87:       in
        !            88:         fun apply(lvar1, lvar2) = APP(VAR lvar1, VAR lvar2)
        !            89: 
        !            90:        fun let_1(lvar, exp1, exp2) = APP(FN(lvar, exp2), exp1)
        !            91: 
        !            92:         fun fn_N(name, lvars, exp) =
        !            93:          let
        !            94:            val vecLvar = inventLvar name
        !            95:            val vecExp = VAR vecLvar
        !            96:            fun doit(lv :: rest, n) =
        !            97:                  let_1(lv, SELECT(n, vecExp), doit(rest, n+1))
        !            98:              | doit(nil, _) = exp
        !            99:          in
        !           100:            FN(vecLvar, doit(lvars, 0))
        !           101:          end
        !           102: 
        !           103:         fun let_N(name, lvars, exp1, exp2) =
        !           104:          APP(fn_N(name, lvars, exp2), exp1)
        !           105: 
        !           106:        fun record lvars = RECORD(map VAR lvars)
        !           107:       end
        !           108: 
        !           109:      (* foldLambda: takes a list of entries (assumed to be in same order
        !           110:        as the actual module declarations), and generates one big lambda.
        !           111:        We close it later. foldLambda returns
        !           112:        {lambda, imports, importLvars}. *)
        !           113: 
        !           114:       fun foldLambda({entry=LAMBDAentry thisFn, lvars} :: rest,
        !           115:                     looker, allVars
        !           116:                    ) =
        !           117:            let
        !           118:              val {lambda=next, imports, importLvars} =
        !           119:                foldLambda(rest, looker, lvars @ allVars)
        !           120:            in
        !           121:              {lambda=thisFn next,      (* apply this fn->lambda to the
        !           122:                                           argument (that's how transDec
        !           123:                                           works...) *)
        !           124:               imports=imports,
        !           125:               importLvars=importLvars
        !           126:              }
        !           127:            end
        !           128: 
        !           129:        | foldLambda({entry=IMPORTentry subMod, lvars} :: rest,
        !           130:                     looker, allVars
        !           131:                    ) =
        !           132:            let
        !           133:              val modLvar =
        !           134:                inventLvar("importModule/" ^ makestring(length rest))
        !           135:              val {lambda=next, imports, importLvars} =
        !           136:                foldLambda(rest, looker, lvars @ allVars)
        !           137:            in
        !           138:              {lambda=let_N("importEntry", lvars, apply(modLvar,looker), next),
        !           139:               imports=subMod :: imports,
        !           140:               importLvars = modLvar :: importLvars
        !           141:              }
        !           142:            end
        !           143: 
        !           144:        | foldLambda(nil, _, allVars) =
        !           145:            {lambda=record(rev allVars), imports=nil, importLvars=nil}
        !           146:                                        (* Make sure the lvars comprising
        !           147:                                           the eventual record are the
        !           148:                                           right way round!! *)
        !           149: 
        !           150:      (* codegen compiles a lambda to a machine-code string. *)
        !           151: 
        !           152:       exception Codegen
        !           153:       fun codegen lambda: string =
        !           154:          let
        !           155:              val _ = debug "codegen...";
        !           156:              val executable = Machm.generate lambda
        !           157:              val _ = debug("done (" ^ makestring(size executable) ^ ").\n");
        !           158:          in
        !           159:              if !ErrorMsg.anyErrors then raise Codegen else executable
        !           160:          end
        !           161: 
        !           162:       fun spaces n =
        !           163:         let
        !           164:           fun spaces'(0, sp) = debug sp
        !           165:             | spaces'(n, sp) = spaces'(n-1, " " ^ sp)
        !           166:        in
        !           167:          spaces'(n, "")
        !           168:        end
        !           169: 
        !           170:       fun printCodeDynModule indent (CODEDYNMODULE{self, subModules}) =
        !           171:         (spaces indent;
        !           172:         debug("CodeDynModule, self=[..." ^ makestring(size self) ^ "...]\n");
        !           173:         spaces indent;
        !           174:         debug "sub-modules=(\n";
        !           175:         app (printCodeDynModule(indent+3)) subModules;
        !           176:         spaces indent;
        !           177:         debug ")\n"
        !           178:        )
        !           179: 
        !           180:       val printNums = app (fn i: int => debug(makestring i ^ " "))
        !           181: 
        !           182:       fun printLambEntry{entry=LAMBDAentry lexpFn, lvars} =
        !           183:             (debug "*LAMBDA*\n";
        !           184:             MCprint.printLexp(lexpFn(record nil));
        !           185:             debug ";\n   lvars=[ ";
        !           186:             printNums lvars;
        !           187:             debug "].\n"
        !           188:            )
        !           189:        | printLambEntry{entry=IMPORTentry dyn, lvars} =
        !           190:            (debug "*IMPORT*\n";
        !           191:             printCodeDynModule 6 dyn;
        !           192:             debug "   lvars=[ ";
        !           193:             printNums lvars;
        !           194:             debug "].\n"
        !           195:            )
        !           196: 
        !           197:       exception CompileDynModule
        !           198:       fun compileDynModule opt (LAMBDYNMODULE entries): CodeDynModule =
        !           199:        let
        !           200:          val _ =
        !           201:            if DEBUG then (debug "compileDynModule:\n";
        !           202:                           app printLambEntry entries
        !           203:                          )
        !           204:            else ()
        !           205: 
        !           206:          val looker = inventLvar "looker"
        !           207: 
        !           208:          val {lambda=openLambda, imports, importLvars} =
        !           209:            foldLambda(rev entries, looker, nil)
        !           210:                (* reverse "entries" because a LambDynModule has the most
        !           211:                   recent declaration at the front, and we want to nest the
        !           212:                   lambda with the old stuff outermost - as well as get the
        !           213:                   correct ordering of the lvars in the final result. *)
        !           214: 
        !           215:          val _ = if !ErrorMsg.anyErrors then raise CompileDynModule else ()
        !           216:                (* Just check for any errors during last part of transDec. *)
        !           217: 
        !           218:          val closedLambda =
        !           219:            Opt.bareCloseTop{lambda=openLambda,
        !           220:                             looker=looker,
        !           221:                             extras=ProcessFile.getCore(),
        !           222:                             keepFree=looker :: importLvars
        !           223:                            }
        !           224:                (* Close the lambda, using the already-generated looker lvar -
        !           225:                   this had to be generated in advance, since each imported
        !           226:                   module is activated as M(looker). We DON'T want to close
        !           227:                   with respect to the modLvars, since we're just about to
        !           228:                   lambda-bind these. Keep the looker's lvar free as well,
        !           229:                   otherwise it tries to find itself... Gnnnh! *)
        !           230: 
        !           231:          val finalLambda =
        !           232:            fn_N("imports", importLvars, closedLambda)
        !           233:                (* That's what we want: "fn (M1, ..., Mn) => fn looker => ..."
        !           234:                   where the Mi's we apply to are each a "fn looker => ...".
        !           235:                   In fact, I suspect that "imports" and "importLvars" are
        !           236:                   both in reverse order, but as long as they're
        !           237:                   coherent... *)
        !           238: 
        !           239:           val _ =
        !           240:            if DEBUG then (debug "Final (unopt) lambda:\n";
        !           241:                           MCprint.printLexp finalLambda;
        !           242:                           debug ".\n"
        !           243:                          )
        !           244:            else ()
        !           245: 
        !           246:          val optLambda = opt finalLambda
        !           247: 
        !           248:          val code =
        !           249:            codegen optLambda
        !           250:            handle Codegen => raise CompileDynModule
        !           251:        in
        !           252:          CODEDYNMODULE{self=code, subModules=imports}
        !           253:        end
        !           254: 
        !           255:      (* primeDynModule: returns a "fn lookup => ...result...". If the module
        !           256:         doesn't import anything, then we just apply the code to NIL. If the
        !           257:        module imports M1...Mn, then we prime these, and build an array of
        !           258:        them. *)
        !           259: 
        !           260:       type object = System.Unsafe.object
        !           261:       type looker = lvar -> object
        !           262:       type result = object array
        !           263:       type module = looker -> result
        !           264: 
        !           265:       fun primeDynModule(CODEDYNMODULE{self, subModules}): module =
        !           266:         let
        !           267:          val me: module array -> looker -> result =
        !           268:            System.Unsafe.boot self
        !           269: 
        !           270:          val subModules: module array =
        !           271:            arrayoflist(map primeDynModule subModules)
        !           272:        in
        !           273:          me subModules
        !           274:        end
        !           275: 
        !           276:       fun debugLooker looker =
        !           277:         fn lvar: int => (debug("[looker(" ^ makestring lvar ^ ")]\n");
        !           278:                         looker lvar
        !           279:                        )
        !           280: 
        !           281:       fun executeDynModule codeDynModule looker: object array =
        !           282:        let
        !           283:          val _ = debug "priming... "
        !           284:          val primed = primeDynModule codeDynModule
        !           285:          val _ = debug "executing... "
        !           286:          val result = primed(if DEBUG then debugLooker looker else looker)
        !           287:          in
        !           288:            debug "done\n";
        !           289:            result
        !           290:          end
        !           291:     end
        !           292:   end;

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.