(* cl-target.sml
 *
 * COPYRIGHT (c) 2011 The Diderot Project (http://diderot-language.cs.uchicago.edu)
 * All rights reserved.
 *
 * Kernels:
 *      <prefix>_GetSizes
 *      <prefix>_InitGlobals
 *      <prefix>_SetInput_<name>        for each input <name>
 *      <prefix>_GetOutput_<name>       for each output <name>
 *)

structure CLTarget : TARGET =
  struct

    structure IL = TreeIL
    structure V = IL.Var
    structure Ty = IL.Ty
    structure CL = CLang
    structure CLN = CLNames
    structure RN = RuntimeNames
    structure ToC = TreeToC
    structure ToCL = TreeToCL
    structure SU = StrandUtil
    structure CLU = CLUtil

    type props = Properties.props

    type var = CL.typed_var
    type exp = CL.exp
    type stm = CL.stm

    datatype strand = Strand of {
        prog : program,
        name : string,
        tyName : string,
        state : var list,
        outputs : (Ty.ty * CL.var) list, (* the strand's output variables *)
        code : CL.decl list ref
      }

    and program = Prog of {
        props : props,                  (* info about target *)
        inputs : GenInputs.input_desc list ref,
        globals : global_var list ref,
	globInit : CL.stm list ref,	(* global initialization code; this gets combined with *)
					(* the setInitDim code. *)
        kernels : string list ref,      (* a list of the OpenCL kernels used by this program *)
        topCDecls : CL.decl list ref,   (* top-level decls for the C file *)
        topOCLDecls : CL.decl list ref, (* top-level decls for the OpenCL file *)
        strands : strand AtomTable.hash_table,
        nAxes : int option ref,         (* number of axes in initial grid (NONE means collection) *)
        initDim : int ref,              (* iteration nesting depth for initially *)
        setInitDim : CL.stm list ref    (* OpenCL code to initialize the initial strand grid/collection size *)
      }

    withtype global_var = {cTy : CL.ty, oclTy : CL.ty, name : string}

    datatype env = ENV of {
        info : env_info,
        vMap : var V.Map.map,
        scope : scope
      }

    and env_info = INFO of {
        prog : program
      }

    and scope
      = NoScope
      | GlobalScope
      | InitiallyScope
      | StrandScope                             (* strand initialization *)
      | MethodScope of StrandUtil.method_name   (* method body; vars are state variables *)

  (* the supprted widths of vectors of reals on the target; we are assuming OpenCL 1.1 or later *)
    fun vectorWidths () = [2, 3, 4, 8, 16]

  (* we do not support printing on the OpenCL target *)
    val supportsPrinting = false

  (* tests for whether various expression forms can appear inline *)
    fun inlineCons n = (n < 2)          (* vectors are inline, but not matrices *)
    val inlineMatrixExp = false         (* can matrix-valued expressions appear inline? *)

  (* OpenCL global pointer type *)
    fun globalPtrTy props = CL.T_Ptr(CL.T_Named(CLN.globalsTy props))

    fun worldPtrTy props = CL.T_Ptr(CL.T_Named(RN.worldTy props))

  (* TreeIL to target translations *)
    structure Tr =
      struct
        fun fragment (ENV{info, vMap, scope}, blk) = let
              val (vMap, stms) = (case scope
                     of GlobalScope => ToC.trFragment (vMap, blk)
                      | InitiallyScope => ToCL.trFragment (vMap, blk)
                      | _ => ToCL.trFragment (vMap, blk)
                    (* end case *))
              in
                (ENV{info=info, vMap=vMap, scope=scope}, stms)
              end
        fun block (ENV{vMap, scope, ...}, blk) = (case scope
               of StrandScope => ToC.trBlock (vMap, blk)
                | MethodScope name => ToCL.trBlock (vMap, blk)
                | InitiallyScope => ToCL.trBlock (vMap, blk)
                | _ => ToC.trBlock (vMap, blk)
              (* end case *))
        fun exp (ENV{vMap, ...}, e) = ToCL.trExp(vMap, e)
      end

  (* variables *)
    structure Var =
      struct
        fun name (ToCL.V(_, name)) = name
        fun global (Prog{globals, ...}, name, ty) = let
              val x = {
                      cTy = CLTyTranslate.toCPUType ty,
                      oclTy = CLTyTranslate.toGPUType ty,
                      name = name
                    }
              in
                globals := x :: !globals;
              (* images require extra support *)
(* FIXME
                case ty
                 of Ty.ImageTy info => imgGlobals := (name, ImageInfo.dim info) :: !imgGlobals
                  | _ => ()
                (* end case *);
*)
                ToCL.V(#oclTy x, name)
              end
        fun param x = ToCL.V(CLTyTranslate.toGPUType(V.ty x), V.name x)
      end

  (* environments *)
    structure Env =
      struct
      (* create a new environment *)
        fun new prog = ENV{
                info=INFO{prog = prog},
                vMap = V.Map.empty,
                scope = NoScope
              }
      (* bind a TreeIL varaiable to a target variable *)
        fun bind (ENV{info, vMap, scope}, x, x') = ENV{
                info = info,
                vMap = V.Map.insert(vMap, x, x'),
                scope = scope
              }
      (* lookup a TreeIL variable *)
        fun lookup (ENV{vMap, ...}, x) = (case V.Map.find(vMap, x)
               of SOME x' => x'
                | NONE => raise Fail("no binding for " ^ V.toString x)
              (* end case *))
      (* define the current translation context *)
        fun setScope (scope, glob, selfIn, selfOut) (ENV{info, vMap, ...}) = ENV{
                info = info,
                vMap = List.foldl
                    (fn ((x, x'), vm) => V.Map.insert(vm, x, x'))
                      vMap [
                          (PseudoVars.global, CL.V(CL.voidTy, glob)),
                          (PseudoVars.selfIn, CL.V(CL.voidTy, selfIn)),
                          (PseudoVars.selfOut, CL.V(CL.voidTy, selfOut))
                        ],
                scope = scope
              }
      (* define the current translation context *)
        val scopeGlobal = setScope (GlobalScope, "glob", "_bogus_", "_bogus_")
        val scopeInitially = setScope (InitiallyScope, "glob", "_bogus_", "_bogus_")
        fun scopeStrand (env as ENV{info=INFO{prog=Prog{props, ...}}, ...}) =
              if Properties.dualState props
                then setScope (StrandScope, "glob", "selfIn", "selfOut") env
                else setScope (StrandScope, "glob", "self", "self") env
        fun scopeMethod (env, name) =
              setScope (MethodScope name, "glob", "selfIn", "selfOut") env
        fun scopeMethod (env as ENV{info=INFO{prog=Prog{props, ...}}, ...}, name) =
              if Properties.dualState props
                then setScope (MethodScope name, "glob", "selfIn", "selfOut") env
                else setScope (MethodScope name, "glob", "self", "self") env
      end

  (* strands *)
    structure Strand =
      struct
        fun define (prog as Prog{strands, ...}, strandId, state) = let
              val name = Atom.toString strandId
            (* the output state variable *)
              val outputVars = let
                    fun cvtOut x = if IL.StateVar.isOutput x
                          then SOME(IL.StateVar.ty x, IL.StateVar.name x)
                          else NONE
                    in
                      List.mapPartial cvtOut state
                    end
            (* the state variables *)
              val state = let
                    fun cvt x = CL.V(CLTyTranslate.toGPUType(IL.StateVar.ty x), IL.StateVar.name x)
                    in
                      List.map cvt state
                    end
              val strand = Strand{
                      prog = prog,
                      name = name,
                      tyName = CLN.strandTy name,
                      state = state,
                      outputs = outputVars,
                      code = ref []
                    }
              in
                AtomTable.insert strands (strandId, strand);
                strand
              end

      (* return the strand with the given name *)
        fun lookup (Prog{strands, ...}, strandId) = AtomTable.lookup strands strandId

      (* register the strand-state initialization code.  The variables are the strand
       * parameters.
       *)
        fun init (Strand{prog=Prog{props, ...}, name, tyName, code, ...}, params, init) = let
              val globTy = globalPtrTy props
              val fName = CLN.strandInit name
              val selfParam = if Properties.dualState props
                    then "selfOut"
                    else "self"
              val params =
                    CLU.globalParam(globTy, "glob") ::
                    CLU.globalParam(CL.T_Ptr(CL.T_Named tyName), selfParam) ::
                      List.map (fn (CL.V(ty, x)) => CLU.clParam(ty, x)) params
              val initFn = CL.D_Func([], CL.voidTy, fName, params, init)
              in
                code := initFn :: !code
              end

      (* register a strand method *)
        fun method (Strand{prog=Prog{props, ...}, name, tyName, code, ...}, methName, body) = let
              val globTy = globalPtrTy props
              val fName = concat[name, "_", StrandUtil.nameToString methName]
              val stateParams = if Properties.dualState props
                    then [
                        CL.PARAM([], CL.T_Ptr(CL.T_Named tyName), "selfIn"),
                        CL.PARAM([], CL.T_Ptr(CL.T_Named tyName), "selfOut")
                      ]
                    else [CL.PARAM([], CL.T_Ptr(CL.T_Named tyName), "self")]
              val params =
                    CLU.globalParam (globTy, "glob") ::
                    stateParams
              val resTy = (case methName
                     of StrandUtil.Update => CL.T_Named "StrandStatus_t"
                      | StrandUtil.Stabilize => CL.voidTy
                    (* end case *))
              val methFn = CL.D_Func([], resTy, fName, params, body)
              in
                code := methFn :: !code
              end

      end

  (* programs *)
    structure Program =
      struct
        fun new (tgt : TargetUtil.target_desc, props : StrandUtil.program_prop list) = let
              val props = Properties.mkProps (tgt, props)
              val kernels = [
                      CLN.getSizesKern,
                      CLN.initGlobalsKern,
                      CLN.initiallyKern,
		      CLN.updateKern
                    ]
              val kernels = if Properties.noBSP props
                    then kernels @ []
                    else kernels @ [
                        CLN.schedKern,
                        CLN.compactKern
                      ]
              in
                RN.initTargetSpec tgt;
                Prog{
                    props = props,
                    inputs = ref [],
                    globals = ref [],
		    globInit = ref [],
                    kernels = ref kernels,
                    topCDecls = ref [],
                    topOCLDecls = ref [],
                    strands = AtomTable.mkTable (16, Fail "strand table"),
                    nAxes = ref(SOME ~1),
		    initDim = ref ~1,
		    setInitDim = ref[]
                  }
              end
      (* gather the inputs *)
        fun inputs (Prog{inputs, ...}, env, blk) = inputs := GenInputs.gatherInputs blk
      (* register the global initialization part of a program *)
	fun init (Prog{globInit, ...}, init) = globInit := CL.unBlock init
      (* register the global destruction part of a program *)
        fun free (Prog{props, topCDecls, ...}, env, globals) = let
              val worldTy = worldPtrTy props
              fun freeGlob (x, stms) = stms (* FIXME *)
              val body = CL.mkBlock(List.foldr freeGlob [CL.mkReturn(SOME(CL.mkVar "false"))] globals)
              val freeFn = CL.D_Func(
                    ["static"], CL.boolTy, RN.freeGlobals,
                    [CL.PARAM([], worldTy, "wrld")],
                    body)
              in
                topCDecls := freeFn :: !topCDecls
              end
      (* create and register the initially function for a program *)
        fun initially {
              prog = Prog{props, strands, topOCLDecls, nAxes, initDim, setInitDim, ...},
              isArray : bool,
              iterPrefix : stm list,
              iters : (var * exp * exp) list,
              createPrefix : stm list,
              strand : Atom.atom,
              args : exp list
            } = let
              val name = Atom.toString strand
              val nDims = List.length iters
              val globTy = globalPtrTy props
            (* create the code to set the initially dimensions in the globals structure; this code
             * will be included in the InitGlobals kernel.
             *)
              val () = let
                    fun lhs (fld, i) = CL.mkSubscript(CL.mkIndirect(CL.mkVar "glob", fld), CL.mkInt i)
                    fun gen ([], _) = []
                      | gen ((_, lo, hi) :: r, i) =
                          CL.mkAssign(lhs("initiallyLo", i), lo) ::
                          CL.mkAssign(lhs("initiallyHi", i), hi) :: gen (r, i+1)
                    in
                      setInitDim := gen (iters, 0)
                    end
            (* create the loop nest for the initially iterations *)
	      fun loopBnd hiOrLo i =
		    CL.mkSubscript(CL.mkIndirect(CL.mkVar "glob", hiOrLo), CL.mkInt i)
              val indexVar = "ix"
              val strandTy = CL.T_Ptr(CL.T_Named(CLN.strandTy name))
              fun statePtr inout = CL.mkAddrOf(CL.mkSubscript(CL.mkVar inout, CL.mkVar indexVar))
              fun mkLoopNest (_, []) = if Properties.dualState props
                    then CL.mkBlock(createPrefix @ [
                        CL.mkCall(CLN.strandInit name, CL.mkVar "glob" :: statePtr "inState" :: args),
                        CL.mkCall("memcpy", [
                            statePtr "outState", statePtr "inState",
                            CL.mkSizeof(CL.T_Named(CLN.strandTy name))
                          ]),
                        CL.S_Exp(CL.mkPostOp(CL.mkVar indexVar, CL.^++))
                      ])
                    else CL.mkBlock(createPrefix @ [
                        CL.mkCall(CLN.strandInit name, CL.mkVar "glob" :: statePtr "state" :: args),
                        CL.S_Exp(CL.mkPostOp(CL.mkVar indexVar, CL.^++))
                      ])
                | mkLoopNest (i, (CL.V(ty, param), _, _)::iters) = let
                    val body = mkLoopNest(i+1, iters)
                    in
                      CL.mkFor(
                        [(ty, param, loopBnd "initiallyLo" i)],
                        CL.mkBinOp(CL.mkVar param, CL.#<=, loopBnd "initiallyHi" i),
                        [CL.mkPostOp(CL.mkVar param, CL.^++)],
                        body)
                    end
              val iterCode = [
                      CL.mkComment["initially"],
                      CL.mkDecl(CL.uint32, indexVar, SOME(CL.I_Exp(CL.mkInt 0))),
                      mkLoopNest (0, iters)
                    ]
              val body = CL.mkBlock(iterPrefix @ iterCode)
              val initKern = CLUtil.mkTaskKernel(
                    CLN.initiallyKern,
                    [ CLU.globalParam(globTy, "glob"),
                      CLU.globalParam(CL.T_Ptr(CL.T_Named(CLN.strandTy (Atom.toString strand))), "state"),
                      CLU.globalParam(CL.T_Ptr CL.uint8, "status")],
                    body)
              in
                nAxes := (if isArray then SOME nDims else NONE);
                initDim := nDims;
                topOCLDecls := initKern :: !topOCLDecls
              end

      (***** OUTPUT *****)

      (* create the target-specific substitution list *)
        fun mkSubs (props : props, Strand{name, tyName, ...}) = [
                ("CFILE",       OS.Path.joinBaseExt{base= #outBase props, ext= SOME "c"}),
                ("HDRFILE",     OS.Path.joinBaseExt{base= #outBase props, ext= SOME "h"}),
                ("CLFILE",      OS.Path.joinBaseExt{base= #outBase props, ext= SOME "cl"}),
                ("PREFIX",      #namespace props),
                ("SRCFILE",     #srcFile props),
                ("PROG_NAME",   #outBase props),
                ("STRAND",      name),
                ("STRANDTY",    tyName),
                ("DIDEROT_FLOAT_PRECISION", Properties.floatPrecisionDef props),
                ("DIDEROT_INT_PRECISION", Properties.intPrecisionDef props),
                ("DIDEROT_TARGET", Properties.targetDef props)
              ]

        fun condCons (true, x, xs) = x::xs
          | condCons (false, _, xs) = xs

        fun verbFrag (props : props, parFrag, seqFrag, subs) =
              CL.verbatimDcl [if (#parallel props) then parFrag else seqFrag] subs

        fun compile (props : props, basename) = let
            (* generate the C compiler flags *)
              val cflags = ["-I" ^ Paths.diderotInclude(), "-I" ^ Paths.teemInclude()]
              val cflags = condCons (#parallel props, #pthread Paths.cflags, cflags)
              val cflags = if #debug props
                    then #debug Paths.cflags :: cflags
                    else #ndebug Paths.cflags :: cflags
              val cflags = #base Paths.cflags :: cflags
              in
                RunCC.compile (basename, cflags)
              end

        fun ldFlags (props : props) = if #exec props
              then let
                val extraLibs = [#cl Paths.extraLibs]
                val extraLibs = Paths.teemLinkFlags() @ #base Paths.extraLibs :: extraLibs
                val rtLib = Properties.runtimeName props
                in
                  rtLib :: extraLibs
                end
              else [Properties.runtimeName props]

        fun genStrandStruct (Strand{prog=Prog{props, ...}, name, tyName, state, ...}) = let
            (* the type declaration for the strand's state struct *)
              val selfTyDef = CL.D_StructDef(
                      NONE,
                      List.rev (List.map (fn CL.V(ty, x) => (ty, x)) state),
                      SOME(CLN.strandTy name))
              in
                selfTyDef
              end

      (* generate an OpenCL struct definition for the globals.  In addition to the user-defined
       * globals, we add variabes to hold the base and size values for the initial grid/collection
       * of strands.
       *)
        fun genGlobalStruct (props, iterDim, globals) = let
              fun genField (projTy : global_var -> CL.ty) gv = (projTy gv, #name gv)
              val intArrTy = CL.T_Array(CL.intTy, SOME iterDim)
              val fields = (intArrTy, "initiallyLo") ::
                    (intArrTy, "initiallyHi") ::
                    List.map (genField #oclTy) globals
              in
                CL.D_StructDef(NONE, fields, SOME(CLN.globalsTy props))
              end

      (* generate the global initialization kernel *)
        fun genGlobInitKern (Prog{props, globInit, setInitDim, ...}) = let
              val globTy = globalPtrTy props
              in
		CLU.mkTaskKernel (CLN.initGlobalsKern,
		  [CLU.globalParam(globTy, "glob")],
		  CL.mkBlock(
		    !globInit @
		    CL.S_Comment["compute size of initial strand grid"] ::
		    !setInitDim))
              end

      (* generate the C function for binding the kernels used by the program *)
        fun genBindKernels (props, kernels) = let
              val worldTy = worldPtrTy props
              fun bindKern (k, stms) =
                    CL.mkAssign(
                      CL.mkIndirect(CL.mkVar "wrld", k),
                      CL.mkApply("clCreateKernel", [
                          CL.mkIndirect(CL.mkVar "wrld", "prog"), CL.mkStr k, CL.mkAddrOf(CL.mkVar "sts")
                        ])) ::
                    CL.mkIfThen(CL.mkBinOp(CL.mkVar "sts", CL.#!=, CL.mkVar "CL_SUCCESS"),
                      CL.mkReturn(SOME(CL.mkVar "true"))) ::
                    stms
              val stms = List.foldr bindKern [CL.mkReturn(SOME(CL.mkVar "false"))] kernels
              val stms = CL.mkDecl(CL.T_Named "cl_int", "sts", NONE) :: stms
              val body = CL.mkBlock stms
              in
                CL.D_Func(["static"], CL.boolTy, "BindKernels", [CL.PARAM([], worldTy, "wrld")], body)
              end

      (* generate the C struct declaration for the world representation *)
        fun genWorldStruct (Prog{props, globals, kernels, ...}) = let
(*
              val extras = if Properties.dualState props
                    then [
                        (CL.T_Ptr(CL.T_Ptr(CL.T_Named tyName)), "inState"),
                        (CL.T_Ptr(CL.T_Ptr(CL.T_Named tyName)), "outState")
                      ]
                    else [
                        (CL.T_Ptr(CL.T_Named tyName),           "state")
                      ]
              val extras = if null(!globals)
                    then extras
                    else (CL.T_Ptr(CL.T_Named(CLN.globalsTy)), "globals") :: extras
              val extras = (CL.T_Ptr CL.uint8, "status") :: extras
*)
              val extras = [
                      (CL.T_Named "cl_int", "gpuDevId"),
                      (CL.T_Ptr(CL.T_Named "Diderot_OCLInfo_t"), "oclInfo")
                    ]
              val extras = if #exec props
                    then extras
                    else (CL.T_Named(RN.definedInpTy props), "definedInp") :: extras
              val extras = (CL.T_Named(#namespace props ^ "Sizes_t"), "oclSizes") :: extras
            (* OpenCL execution context *)
              val extras =
                    (CL.T_Ptr(CL.T_Named "Diderot_DeviceInfo_t"), "device") ::
                    (CL.T_Named "cl_context", "context") ::
                    (CL.T_Named "cl_command_queue", "cmdQ") ::
                    (CL.T_Named "cl_program", "prog") :: extras
            (* add fields for GPU memory objects *)
              val extras =
                    (CL.T_Named "cl_mem", "globalsBuf") ::
                    (CL.T_Named "cl_mem", "stateBuf") ::
                    (CL.T_Named "cl_mem", "statusBuf") :: extras
            (* add a field for each kernel *)
              val extras = let
                    fun kField (k, extras) = (CL.T_Named "cl_kernel", k) :: extras
                    in
                      List.foldl kField extras (!kernels)
                    end
              in
                World.genStruct (props, List.rev extras)
              end

        fun genIntially (Prog{nAxes, initDim, ...}, substitutions) = CL.verbatimDcl [CInitiallyFrag.text]
              (("INIT_DIMS", Int.toString(! initDim)) ::
              ("IS_ARRAY", Bool.toString(isSome(! nAxes))) :: substitutions)

        fun genRun (Prog{props, ...}, substututions) =
              if Properties.noBSP props
                then CL.verbatimDcl [CRunNoBSPFrag.text] substututions
                else CL.verbatimDcl [CRunFrag.text] substututions

        type output = {file : string, outS : TextIO.outstream, ppStrm : TextIOPP.stream}

      (* open pretty printing streams for both the C and OpenCL output files *)
        fun openOut baseName = let
              fun openOut (mkPP, ext) = let
                    val fileName = OS.Path.joinBaseExt{base=baseName, ext=SOME ext}
                    val outS = TextIO.openOut fileName
                    in {
                      file = fileName,
                      outS = outS,
                      ppStrm = mkPP outS
                    } end
              in
                {cOut = openOut (PrintAsC.new, "c"), oclOut = openOut (PrintAsCL.new, "cl")}
              end

        fun closeOut {file, outS, ppStrm} = (
              TextIOPP.closeStream ppStrm;
              TextIO.closeOut outS)

      (* generate the OpenCL source code. *)
        fun outputCLSrc (out : output, prog, strand, substitutions) = let
              val Prog{props, nAxes, initDim, globals, topOCLDecls, ...} = prog
              val Strand{outputs, code=strandCode, ...} = strand
              val outputs = GenOutput.genKernels (props, !nAxes) outputs
              fun ppDecl dcl = PrintAsCL.output(#ppStrm out, dcl)
              in
              (* Retrieve the header information *)
                ppDecl (CL.verbatimDcl [CLHeadFrag.text] substitutions);
(* FIXME: check to see if we really need the DUAL_STATE define for OpenCL *)
                if Properties.dualState props
                  then ppDecl (CL.D_Verbatim ["#define DIDEROT_DUAL_STATE\n"])
                  else ();
		if #hasDie props
		  then ppDecl (CL.D_Verbatim ["#define DIDEROT_HAS_DIE\n"])
		  else ();
              (* type definitions *)
                ppDecl (genGlobalStruct (props, !initDim, !globals));
                ppDecl (genStrandStruct strand);
(* FIXME: should only include eigen code fragments if they are being used! *)
(* comment out for debugging
                ppDecl (CL.D_Verbatim[CLEigen2x2Frag.text]);
*)
(* FIXME: should only include eigen code fragments if they are being used! *)
(* comment out for debugging
                ppDecl (CL.D_Verbatim[CLEigen3x3Frag.text]);
*)
		ppDecl (genGlobInitKern prog);
                List.app ppDecl outputs;
                List.app ppDecl (!strandCode);
                List.app ppDecl (!topOCLDecls);
              (* Specialize the scheduler kernels and functions *)
                if Properties.noBSP props
                  then ppDecl (CL.verbatimDcl [CLSchedNoBSPFrag.text, CLUpdateNoBSPFrag.text] substitutions)
                else if Properties.noComm props
                  then ppDecl (CL.verbatimDcl [CLSchedFrag.text, CLUpdateNoComFrag.text] substitutions)
                  else ppDecl (CL.verbatimDcl [CLSchedFrag.text, CLUpdateFrag.text] substitutions);
              (* kernel for computing sizes of runtime data structures *)
                ppDecl (CL.verbatimDcl [CLSizesFrag.text] substitutions)
              end

      (* output common C source that is common to both the library and standalone targets *)
        fun outputCSrc (out : output, prog, strand, substitutions) = let
              val Prog{props, nAxes, inputs, kernels, ...} = prog
              fun ppDecl dcl = PrintAsC.output(#ppStrm out, dcl)
              in
                if Properties.dualState props
                  then ppDecl (CL.D_Verbatim ["#define DIDEROT_DUAL_STATE\n"])
                  else ();
              (* generate the host-side type definitions *)
                ppDecl (CL.verbatimDcl [CShadowTypesFrag.text] substitutions);
                ppDecl (CL.verbatimDcl [CSizesFrag.text] substitutions);
                ppDecl (GenInputs.genDefinedInpStruct (props, !inputs));
                ppDecl (genWorldStruct prog);
                ppDecl (GenInputs.genInputsStruct (props, !inputs));
              (* support code for OpenCL *)
                ppDecl (CL.verbatimDcl [
                    CCheckCLStatusFrag.text
                  ] substitutions);
              (* kernel binding *)
                ppDecl (genBindKernels (props, !kernels))
              end

        fun outputLibSrc (out : output, prog, strand, substitutions) = let
              val Prog{props, inputs, topCDecls, nAxes, ...} = prog
              val Strand{outputs, ...} = strand
              val outputs = GenOutput.gen (props, !nAxes) outputs
              fun ppDecl dcl = PrintAsC.output(#ppStrm out, dcl)
              in
                ppDecl (CL.verbatimDcl [LibHdrFrag.text] substitutions);
                outputCSrc (out, prog, strand, substitutions);
                List.app ppDecl (GenInputs.genInputFuns(props, !inputs));
                List.app ppDecl (!topCDecls);
                List.app ppDecl outputs;
                ppDecl (CL.verbatimDcl [CBodyFrag.text] substitutions);
                ppDecl (CL.verbatimDcl [CInitFrag.text] substitutions);
                ppDecl (genIntially (prog, substitutions));
                ppDecl (genRun (prog, substitutions));
                ppDecl (CL.verbatimDcl [CShutdownFrag.text] substitutions)
              end

        fun generateLib (prog as Prog{props, inputs, strands, ...}) = let
              val {outDir, outBase, exec, double, parallel, debug, ...} = props
              val [strand] = AtomTable.listItems strands
              val basename = OS.Path.joinDirFile{dir=outDir, file=outBase}
              val [Strand{state, outputs, ...}] = AtomTable.listItems strands
              val {cOut, oclOut} = openOut basename
              val substitutions = mkSubs(props, strand)
              in
              (* generate the library .h file *)
                GenLibraryInterface.gen {
                    props = props,
                    rt = SOME CLibInterfaceCLFrag.text,
                    inputs = !inputs,
                    outputs = outputs
                  };
              (* generate source code *)
                outputLibSrc (cOut, prog, strand, substitutions);
                outputCLSrc (oclOut, prog, strand, substitutions);
              (* close the output streams *)
                closeOut cOut;
                closeOut oclOut;
              (* compile and link *)
                compile (props, basename);
                RunCC.linkLib (basename, ldFlags props)
              end

        fun outputExecSrc (out : output, prog, strand, substitutions) = let
              val Prog{props, inputs, topCDecls, strands, nAxes, ...} = prog
              val Strand{outputs, ...} = strand
              val outputs = GenOutput.gen (props, !nAxes) outputs
              fun ppDecl dcl = PrintAsC.output(#ppStrm out, dcl)
              in
                ppDecl (CL.verbatimDcl [ExecHdrFrag.text] substitutions);
                outputCSrc (out, prog, strand, substitutions);
                List.app ppDecl (GenInputs.genExecInputFuns (props, !inputs));
                List.app ppDecl (!topCDecls);
                List.app ppDecl outputs;
                ppDecl (CL.verbatimDcl [CInitFrag.text] substitutions);
                ppDecl (genIntially (prog, substitutions));
                ppDecl (genRun (prog, substitutions));
                ppDecl (CL.verbatimDcl [CShutdownFrag.text] substitutions);
                ppDecl (CL.verbatimDcl [CMainFrag.text] substitutions)
              end

      (* output the code to a file.  The string is the basename of the file, the extension
       * is provided by the target.
       *)
        fun generateExec (prog as Prog{props, strands, ...}) = let
              val {outDir, outBase, exec, double, parallel, debug, ...} = props
              val [strand] = AtomTable.listItems strands
              val basename = OS.Path.joinDirFile{dir=outDir, file=outBase}
              val {cOut, oclOut} = openOut basename
              val substitutions = mkSubs(props, strand)
              in
                outputExecSrc (cOut, prog, strand, substitutions);
                outputCLSrc (oclOut, prog, strand, substitutions);
              (* close the output streams *)
                closeOut cOut;
                closeOut oclOut;
              (* compile and link *)
                compile (props, basename);
                RunCC.linkExec (basename, ldFlags props)
              end

        fun generate (prog as Prog{props, globals, topCDecls, ...}) = (
              globals := List.rev (!globals);
              topCDecls := List.rev (!topCDecls);
              if #exec props
                then generateExec prog
                else generateLib prog)

      end

  end

structure CLBackEnd = CodeGenFn(CLTarget)